diff options
Diffstat (limited to 'libguile')
160 files changed, 0 insertions, 47640 deletions
diff --git a/libguile/.cvsignore b/libguile/.cvsignore deleted file mode 100644 index e4632e405..000000000 --- a/libguile/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -Makefile -config.log -config.status -config.cache -fd.h -scmconfig.h -*.x -libpath.h
\ No newline at end of file diff --git a/libguile/COPYING b/libguile/COPYING deleted file mode 100644 index 9648fb9ea..000000000 --- a/libguile/COPYING +++ /dev/null @@ -1,339 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/libguile/ChangeLog-scm b/libguile/ChangeLog-scm deleted file mode 100644 index 0ba497ed7..000000000 --- a/libguile/ChangeLog-scm +++ /dev/null @@ -1,2610 +0,0 @@ -Wed Apr 5 14:32:51 1995 Gary Houston <ghouston@actrix.gen.nz> - - * unix.c, ioext.c, posix.c, sys.c: Scheme name changes, - semantic cleanups, the port table, missing system calls - and coding cleanups from ghouston@actrix.gen.nz - -Thu Mar 16 14:37:38 1995 Tom Lord <lord@x1.cygnus.com> - - * guile.c: fixed the gcc-specific definition of the macro "AT(x)". - - * guile.c (gscm_init_from_fn): Parameterize what init functions - get called (see guile_ks, below). - - * guile-mini.c (guile_mini): a minimalist alternative to guile_ks. - - * guile-ks.c (guile_ks): factor out the call to optional inits to - a separate file so you can link against libguile without getting - the kitchen sink. - - * Ginit.scm (try-load of "ScmInit.scm"): Be robust in the absense - of a binding for the environment varialbe HOME. Try - (getpw (geteuid)) or just use "/". - - -Thu Mar 9 15:35:20 1995 Tom Lord <lord@x1.cygnus.com> - - * gmain.c (main): Print additional error message if init file - can't be opened. - - * guile.c (initialize_gscm): Report an error if the - init file can't be opened. - -Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (I/O-Extensions): Finished. - - * Init.scm (scm:load): `loading' messages now indented. - -Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi: documentation finished for "posix.c" and "unix.c". - - * posix.c (scm_getgroups): added. - - * posix.c (makfrom0str): According to glibc.info, some field in - structures like pwent may have NULL pointers. Changed makfrom0str - to return BOOL_F in this case. - -Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal) - - * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware - HighC ported. - - * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was - __STDC__). This allows an overly fussy compiler to still have - __STDC__. - - From: dorai@ses.com (Dorai Sitaram) - * ioext.c (l_utime): include files fixed for __EMX__ - -Sun Feb 26 23:46:18 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_app_wdr): Like scm_apply, but takes an error function. - The caller's continuation is never captured or escaped. - The error function is invoked as with scm_cwdr. - -Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal) - - * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it - gets used for non-GCed strings in scm_evalstr scm_loadstr. - (mkstrport cwos cwis): changed so caller's name is passed into - mkstrport(). - - * repl.c - (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added - for easier C to scheme callbacks. - (loadport): variable added so lreadr() and flush_ws() - increment linum only when reading from the correct port. - (def_err_response): now handles ARGn for argument numbers > 5 and - unknown position arguments. - - * dynl.c: Dynamic Linking now sets and restores *load-pathname* - around the init_ call. - -Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c. - (add_feature): moved from repl.c. - (features): init table removed (caused multiple symbols). - -Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.c (scm_init_extensions COMPILED_INITS): Added so that - statically linked, compiled code can be initialized *after* most - of Init.scm has loaded. - -Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal) - - * subr.c (append): Added check for bad arguments and fixed errobj. - -Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (exec execp): changed so that 2nd arguments is argv[0] - (like posix) and renamed to execl and execlp. - (execv execvp): added. - -Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (lexec): moved from repl.c and scm.c. - (lexecp i_exec l_putenv): added. - - * posix.c (open_pipe l_open_input_pipe l_open_output_pipe - prinpipe): moved from ioext.c. - (l_fork): added. - -Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal) - - * scl.c (num2long long2num): moved here from subr.c. - (num2ulong): fixed (< to >=) bug. - - * unif.c (aset array2list array_ref cvref): uniform integers and - unsigned integer arrays now handle full size integers (and - inexacts) using num2long, num2ulong, long2num, and ulong2num when - INUMS_ONLY is not defined. - - * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers. - -Wed Feb 8 17:57:26 1995 Tom Lord (lord@x1.cygnus.com) - - * Ginit.scm (stand-alone-repl): Use new function (rooted-repl) - (rooted-repl): new function - -Tue Jan 31 16:46:26 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c (lreadr): compare string constant names - in a case insensative way. - - (scm_lread): Take an optional parameter CASEP. - If specified and not #f, then symbols are read - in a case sensative way. - - If not specified, the state variable default_case_i is checked - (a C int, either 0 or 1). The state variable hasn't been - exposed and so is constant and depends on compile-time flags -- - but in the future it might be made more explicit if there is a - need. - -Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (Overview): scm.1 converted to texinfo format and - incorporated. - -Sat Jan 28 23:11:40 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c (compiled-library-path): return the value of the - compile-time cpp macro "LIBRARY_PATH" or #f. - - * Ginit.scm: use the above path to find slib on unix. - This solution should be generalized. - -Fri Jan 27 19:58:27 1995 Tom Lord (lord@x1.cygnus.com) - - * sys.c (gc_sweep): Fixed a gc bug that caused circular free-lists - resulting in Cells that thought they were free long after they - were allocated for some nefarious purpose or other. - - * Makefile.in (manifest): ship all pieces of the info manual. - Typos fixes from ghouston. - -Thu Jan 26 01:52:00 1995 Tom Lord <lord@x1.cygnus.com> - - From: cessu@cs.hut.fi (Kenneth Oksanen) - - * configure.in: - AC_CHECK_LIB(nsl, gethostent) - AC_CHECK_LIB(ucb, bzero) - AC_CHECK_LIB(socket, socket) - AC_CHECK_LIB(bsd, bzero) - - - From: brent@jade.ssd.csd.harris.com (Brent Benson) - - * gmain.c: line 31: In ANSI C, string literals cannot span multiple - source lines. - - * guile.c: line 592: The two cases in the ifdef are reversed, AT(X) - should expand to nothing if you are *not* using GNUC. - - * ioext.c: line 29: On my system it is necessary to - include <unistd.h> *before* <sys/stat.h> in order to - have the correct types defined. - - * ioext.c: line 194: Declaration of popen conflicts with my system's - popen() defined in <unistd.h>. Let the header file provide the - prototype!! - -Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (Internals): code.doc converted to texinfo format. - Much added and reorganized. code.doc removed. - -Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal) - - * subr.c (logbitp logtest): added. - -Mon Jan 16 01:42:20 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_repl): takes two arguments now (prompt and top-level). - Callable from Scheme. - - * sys.c (scm_init_storage): only use stdin if scm_take_stdin is true. - Otherwise, use an empty string port. If using stdin, make it - unbuffered. - -Sun Jan 15 21:51:37 1995 Tom Lord <lord@x1.cygnus.com> - - * sys.c (scm_mkarray, scm_free_array, mark_arrays): support for - C programs. malloc/free style interface to allcoating - protected storage of type SCM*. - -Sun Jan 15 17:49:43 1995 Tom Lord (lord@x1.cygnus.com) - - * guile.c: new file. Friendly C interface for Guile. - (see file GUILE) - - * repl.c (scm_cwdr): added call-with-dynamic-root (see scm.texi). - -Sat Jan 14 23:35:21 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c, subr.c: re-arrangement, commenting - of source in preparation for pulling repls apart - for libguile. - -Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal) - - * scl.c (num2ulong): checks for bignum sign and magnitude added. - - * subr.c (logand logior logxor lognot): lognot restriction to - INUMs removed. Logand, logior, and logxor now will work for up to - 32 bit signed numbers. - -Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal) - - * repl.c (def_err_response): Circuitous call to quit() replaced - with exit(EXIT_FAILURE); - (everr): Now calls def_err_response() in interrupt frame if - errjmp_bad or there are dynwinds to do. This prevents silent - failure in batch mode. - - -Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal) - - * repl.c (handle_it): Now discards possibly used top freelist cell - for GC safety. Also now just punts if errjmp_bad. - - * scm.texi: converted from MANUAL. GUILE documentation merged in. - -Sat Jan 7 13:51:04 1995 Miles Bader (miles@eskimo.com) - - * mrequire.scm: New file: Wrapper for slib require/provide that - makes it modular (that is, each slib package is loaded into its - own module, and sees only other modules that it requires). - - * defmod.scm: Allow use-interface in the default module. - - * libguile.scm: Put symbols common to both guile and scm - interfaces into the internal interface `EXTRA' (which is included - by both). Other random shuffling, mostly to make slib happy. - - * modops.scm (extend-interface, export-interface, export): Add - another operation type, #f, which turns off automatic exporting of - the current source interface when finishing up with it. This is - used by export-interface to prevent trying to export all symbols. - - * modops.scm (import): No longer signal an error when trying to - export a whole module, as we want to do this sometimes. - - * Ginit.scm: No longer try to load require.scm, or depend on it; - In the case of getopt, we just load it manually. Also make - defmacro module-safe. - -Sat Jan 7 01:54:11 1995 Tom Lord <lord@x1.cygnus.com> - - * sys.c (scm_intern_obarray_soft): Reserve room for symbol slots. - - * sys.c (scm_makstr, scm_makfromstr): added an extra parameter SLOTS. - The parameter means: - 0: same as the old behavior - 1: not useful - > 1: allocate SLOTS - 1 extra slots in the string storage. - - The base address of SLOTS, an array of SCM, is at SLOTS(obj). - This is for symbol slots, and later for procedure slots. - If you use this in the constructor for your new type (usually - done by creating a string and then invoking SETLENGTH to change - its type), you are responsible for making sure slot contents - are properly gc'ed. - - Callers of these were fixed as well. - -Tue Jan 3 14:30:34 1995 Miles Bader (miles@eskimo.com) - - * modops.scm, extlibs.scm, libguile.scm, defmod.scm: New files: - These implement the user-level module system. - - * sys.c (scm_sym2vcell): Add another argument: definedp, which is - passed as additional argument to the lookup-thunk (if any). - If this argument is BOOL_T, this lookup is for a define (which - has somewhat different semantics for modules); otherwise it - should be satisfied with an existing variable. If the thunk - returns BOOL_F (meaning there was no such variable), sym2vcell - returns BOOL_F as well. - * eval.c (scm_lookupcar, scm_m_define): Use the new sym2vcell param. - * variable.c (scm_builtin_var): Use the new sym2vcell param. - - * eval.c (scm_top_level_env): New function: return an environment - using the given top-level-lookup thunk. - * eval.c (scm_eval2): Use scm_top_level_env. - * eval.c (scm_eval): Use an env with a top-level lookup thunk from - scm_top_level_lookup_thunk_var (aka *top-level-lookup-thunk*). - * eval.c (scm_neval): New function: just like scm_eval, but may - destroy its argument. Known in scheme as eval!. - - * repl.c (scm_repl, scm_tryload, lreadr): Use scm_neval, not eval_3. - - * Ginit.scm (make-module): Use the new definition of top-level thunks. - * Ginit.scm (set-current-module): Set *top-level-lookup-thunk* too. - * Ginit.scm: Trash all the repl stuff; we just use the C repl now. - Load the user module system. - - * Makefile.in: Install the user-module implementation files. - -Mon Jan 2 16:27:25 1995 Miles Bader (miles@eskimo.com) - - * Ginit.scm (repl:repl): Have the guile repl redefine try-load - instead of load, as this is the SCM primitive. - (module-for-each): Write module-for-each. - (module-search): Make this recurse into each module use-list - entry, as per the low-level module spec. - (define-macro): Make this function usable by modules that don't - have access to the internals of the guile module. - -Sun Jan 1 22:30:25 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_iprin1), subr.c (scm_lock_vector, scm_unlock_vector, - scm_lvector_ref, scm_lvector_set): - - Added locked vectors. See N - -Sat Dec 31 15:45:22 1994 Miles Bader <miles@eskimo.com> - - * Ginit.scm: - Add define-macro, delq!. - - Add a module print-function, and some new name fields - to the module that the modops code uses to make modules - print nicely (e.g., #<interface guile/module 7a89c>) - - - * eval.c(ceval): Here's a patch that makes closures & subrs - self-evaluating. - - -Wed Dec 28 00:31:22 1994 Tom Lord <lord@cygnus.com> - - * scm.c (raise): use kill not raise, since it is more portable. - -Wed Dec 21 05:18:47 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_eval2): Two argument eval. The - second argument is #f or a proc returning a variable. - -Fri Dec 9 00:40:26 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_fasl_eval): eval without copying the source form. - This is just a temporary hack. - -Sun Dec 4 21:50:37 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_ceval): Added special forms LITERAL-VARIABLE-SET! - and LITERAL-VARIABLE-REF. The first argument of each is a - variable object (see variable.c). The second argument - of set! is an expression. They do what you'd expect. - -SET! returns UNSPECIFIED. - - Note that one can not read a form which uses literal-variable* - correctly because there is no way to read a variable object. - These forms exist for the sake of the module system. - -Fri Dec 2 19:52:40 1994 Tom Lord (lord@x1.cygnus.com) - - * subr.c (string->obarray-symbol, intern-symbol, unintern-symbol, - symbol-set!, symbol-binding) - Multiple obarrays. - - * variable.c (scm_make_variable, scm_variable_{ref,set} - Implemented variables. Variables are anonymous - objects holding one settable value. - -Wed Nov 30 04:31:18 1994 Tom Lord (lord@x1.cygnus.com) - - * *.[ch]: renamed all global identifiers to have the prefix scm_. - - * sys.c (gc_sweep, scm_mark_locations, scm_init_heap): - - Modified gc to allow objects of any multiple of sizeof(CELLPTR). - In addition, each heap segment gets to specify a freelist (which - may be shared). - - new function: scm_alloc_obj - new vars: scm_heap_table (replaces hplims) - scm_n_heap_segs (replaces (hpims_ind / 2)) - -Thu Oct 27 12:57:02 1994 Aubrey Jaffer (jaffer@jacal) - - From: Jerry D. Hedden <hedden@esdsdf.dnet.ge.com> - * ioext.c: conditional code for vms and version (3.6) of Aztec C. - * pi.scm ((e digits)): Modified 'bigpi' for slight speed - improvement. Added function to calculate digits of 'e'. - -Wed Oct 26 11:22:05 1994 Aubrey Jaffer (jaffer@jacal) - - From: Gary Houston <ghouston@actrix.gen.nz> - * scl.c (round): Now rounds as described in R4RS. - - * test.scm (test-inexact): test cases for round. - -Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (grow_throw lthrow dynthrow): now pass arrays, check - for adequate growth, and clear out register windows (on sparc). - -Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (ttyname fileno): added. - -Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal) - - * unix.c (symlink readlink lstat): added. - - * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed. - - * ioext.c (read-line read-line! file-position, file-set-position - reopen-file open-pipe opendir readdir rewinddir closedir chdir - umask rename-file isatty? access chmod mkdir rmdir stat utime - raise): moved from "repl.c" and "sys.c". - -Fri Oct 21 21:19:13 1994 Aubrey Jaffer (jaffer@jacal) - - From: Radey Shouman <shouman@ccwf.cc.utexas.edu> - * unif.c (ra2contig): now has a second parameter to indicate - whether copying is necessary or not. Eliminates gratuitous copy - by UNIFORM-ARRAY-READ! when called with a noncontiguous array. - - (array_map): more liberal check on when ARRAY-MAP! can use - array-ified asubrs. - -Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (opendir readdir rewinddir closedir reopen-file): added - under IO_EXTENSIONS. - -Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (badargsp): added under ifndef RECKLESS to check @apply - and apply() arg counts. - -Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal) - - * unix.c (mknod acct nice sync): added. - - * socket.c (socket bind! gethost connect! listen! accept): added. - - * time.c (utime): added under IO_EXTENSIONS. - -Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (getcwd umask access chmod mkdir rmdir): added - under IO_EXTENSIONS. - - * scm.c (l_pause): added if SIGALRM defined. - (l_sleep): added if SIGALRM not defined. - - * scl.c (num2ulong): added. Used in "time.c" - -Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (access chmod): Posix access added under IO_EXTENSIONS. - -Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal) - - * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id, - set*id): added. - - * time.c (l_raise l_getpid): added - * subr.c (ulong2big): - * scl.c (ulong2num): useful routines for system call data - conversion moved from "time.c". - -Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal) - - * subr.c (big2inum): (more accruately) renamed from big2long. - -Tue Sep 6 22:22:16 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@hpcf.cc.utexas.edu (Radey Shouman) - Date: Mon, 29 Aug 1994 11:36:46 +0600 - * unif.c: This is a large patch, but also a bit larger than it - appears -- I moved a few function definitions around to eliminate - gratuitous forward references. - - * unif.c repl.c (raprin1): Combined print routine for arrays with - that for uves. - - * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general - arrays, by copying when necessary, renamed them to - UNIFORM-ARRAY-READ! and -WRITE. - - * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d - array even when the stride in the last dimension is greater than - one, gave it an optional second argument STRICT, which makes it - behave as it did before, returning an array/vector only if the - contents are contiguous in memory. - - * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use - (lambda (ra) (array? (array-contents ra #t))) - - * unif.c code.doc (ramapc): unrolls arrays mapping into one loop - if possible, to make this quick, changed the format of the array - CAR, now uses one bit to indicate that an array is contiguous -- - this still allows a ridiculous number of dimensions. - - * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I - moved the typedef for dsubr and #define for DSUBRF to scm.h - - * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs - may be mapped without going through apply(), saving time and - reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped - directly as special cases -- for uniform arrays this is nearly as - fast as the equivalent C, and doesnt' cons. I've made sure that - +, -, *, and / vectorize on the CRAY, this may be wasted effort - but the effort is not great. - - * unif.c (ARRAY-COPY!) now copies many arrays of differing types - to each other without going through the aref/aset, e.g. float -> - double, double -> complex, integer -> float ... This should make - array type coercions for arithmetic faster. - - * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array - that is the transpose of its first argument. I think this does - what an APL:TRANSPOSE would. - - * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks - like an array of shared arrays, the difference being that the - shared arrays are not actually allocated until referenced. - Internally, the contents of an enclosed array is another array. - The main reason for this is to allow a reasonably efficient - implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to - actually make an array of shared arrays, just use ARRAY-COPY!. - - * unif.c (cvref): Created internal version of aref(), cvref() that - doesn't do error checking; Thus speeding things up. Profiling of - SCM running array code revealed that aref() was taking a - surprising fraction of the CPU time - - TO DO: - - The mechanism for looking up the vectorized functions is a little - kludgy, I was tempted to steal some of the CAR of the subr type to - encode an offset into a table of vectorized functions, but this - would make it more likely that dynamically loaded subrs lose thier - names. - - It is almost possible to write APL:+ and friends now, it is just - necessary to figure out the appropriate type of the returned array - and allocate it, and to promote scalar arguments to arrays (with - increments 0). - - This doesn't include vectorized REAL-PART, IMAG-PART, - MAKE-RECTANGULAR ... - - I think some C support for APL:REDUCE and maybe INNER-PRODUCT will - be needed for a reasonably fast APL.scm - - unif.c is getting quite big, time to split it up? - - -Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm repl.c (quit): code was not using return values - correctly. - -Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal) - - * record.c (init_record): remaining record functions moved into C - code. - * eval.c sys.c: compiled closures now conditional under CCLO. - -Sat Aug 20 23:03:36 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * eval.c (ceval apply): - * sys.c (makcclo): tc7_cclo, compiled closures, now supported. - * record.c (init_record): C implementation of slib "Record"s using - CCLO. - * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for - bignums with DIGSTOOBIG defined. Also, changed the return type of - longdigs() to void, since that value is no longer used anywhere. - -Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal) - - * time.c (curtime): replaces get-universal-time. Other time - functions removed (SLIB support more complete). - - * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400 - bug. Also added to test.scm. - -Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal) - - * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically - (ldso) linked libc.sa and libm.sa (under Linux). - -Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal) - - * unif.c (array-fill!): bug with increment in default clause fixed. - Fast string support added. - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c (array-fill! array-for-each): bug fixes. - -Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.c (run_scm init_scm): "-a" heap allocation argument supported. - - * Makefile (proto.h): removed. - - From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au - * scm.h (P): Conditionalized ANSI'fied version of the scm.h. - -Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm (usr:lib lib): Now checks for shared libraries - (lib*.sa) first. - -Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal) - - * scl.c scm.c: Support for compilation under Turbo C++ for Windows - (system and exec disabled) added under C flag "_Windows". - -Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal) - - * test.scm ((test-delay)): added. - ((test-bignum)): added and called automatically if bignums - suported. test-inexact called automatically if inexacts - supported. - -Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm (trace untrace): moved to SLIB/trace.scm. - -Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm: Autoload for hobbit now does (provide 'hobbit). This - allows hobbit to know if it is self compiling (although reloads of - hobbit will not be quite right). - ((compile file . args)): removed. - - * makefile.unix (proto.h): removed. - - * Transcen.scm: compile-allnumbers HOBBIT declaration added. - Init.scm will now load compiled Transcen.o. - - * scm.h: HOBBIT section removed. - - * README (SLIB): Now strongly recommends getting SLIB and lists - ftp sites. - - * eval.c (m_delay): fixed bug with multiple sets of (delay x). - -Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal) - - * unif.c (makflo): shortcut for single precision float arrays - added. - -Fri Apr 15 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: no longer uses pointer comparisons in loops. Should - fix problems on 8086 processors. - * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared - arrays with only 1 element in some direction may still be - ARRAY-CONTIGUOUS? - (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE, - UNIFORM-ARRAY_READ!. Now they do the right thing for shared - bit-arrays not starting at the beginning of their contents vector. - (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a - shared, contiguous, 1-d array, instead of a vector, if the array - cannot access all of the contents vector. ARRAY-SIMPLE? removed. - (array-fill!): a replacement and generalization of - UNIFORM-VECTOR-FILL!. - (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL? - ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are - uniform vectors or if all are arrays. It differs from EQUAL? in - that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector. - for example - (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1) - (equal? '#(0 1) sh) ==> #F - (array-equal? '#(0 1) sh) ==> #T - (list2ura): Combines list2uve() and list2ura(). - -Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal) - - * time.c (LACK_FTIME LACK_TIMES): defined for vms. - -Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (copytree): now copies vectors as well. - - * repl.c (quit): now accepts #t and #f values. - -Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal) - - * repl.c (repl): call to my_time() moved to not include READ time. - - * time.c (mytime): now prefers to use times() over clock(). - Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is - moved between machines. - -Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm (*SCM-VERSION*): added. - - * Makefile (intro): Added message for those who just make. - Cleaned up and reorganized Makefile. - - * patchlvl.h (PATCHLEVEL): removed. Whole version now just in - SCMVERSION. - -Wed Mar 23 00:09:51 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * repl.c (iprin1): Characters higher than 127 print as - #\<octal-number>. - - * Init.scm ((read:array digit port)): added. Most # syntax - handled in read:sharp. - - * unif.c (clist2uve clist2array): removed. - -Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu) - - * sys.c (sfgetc): can now return EOF. - -Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal) - - * patchlvl.h (SCMVERSION): 4e0 - - * scmfig.h: was config.h (too generic). - - * scm.c (main run_scm) repl.c (repl_driver init_init): now take - initpath argument. IMPLINIT now used in scm.c - -Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation - special form for tail recursive call-with-current-continuation - added. call_cc() routine removed. - -Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply - special form for tail-recursive apply added. ISYMs reactivated. - -Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal) - - * crs.c (nodelay): added. In NODELAY mode WGETCH returns - eof-object when no input is ready. - - * Init.scm ((read:sharp c port)): defined to handle #', #+, and - #-. - - * repl.c (lreadr): Now calls out to Scheme function read:sharp - when encountering unknown #<char>. - -Tue Feb 15 01:08:10 1994 Aubrey Jaffer (jaffer@jacal) - - From: Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp> - * eval.c (ceval apply): under flag CAUTIOUS, checks for applying - to non-lists added. - -Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (sym2vcell intern sysintern): now use internal strhash(). - - * scl.c sys.c (hash hashv hashq strhash()): added. - -Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to - #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next. - -Fri Feb 4 23:15:21 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: 0d arrays added. Serial array mapping functions and - ARRAY-SIMPLE? added. - -Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.h (LENGTH): now does unsigned shift. - -Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm (*catalog*): catalog entries for db (wb), - turtle-graphics, curses, regex, rev2-procedures, and - rev3-procedures added. - -Sun Jan 30 19:25:24 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * sys.c eval.c setjump.h setjump.s (longjump setjump): full - continuations now work on Cray YMP. - -Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal) - - * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for - modern linux. - -Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal) - - From: ucs3028@aberdeen.ac.uk (Al Slater) - * makefile.acorn repl.c (set_erase): Port to acorn archimedes. - This uses Huw Rogers free unix function call library for the - archimedes - this is very very widely available and should pose no - problem to anyone trying to find it - its on every archimedes ftp - site. - - From: hugh@cosc.canterbury.ac.nz (Hugh Emberson) - * dynl.c Link.scm: Dynamic Linking with SunOS. - -Thu Jan 6 22:12:51 1994 (jaffer at jacal) - - * sys.c (gc_mark mark_locations): now externally callable. - -Sun Jan 2 19:32:59 1994 (jaffer at jacal) - - From: fred@sce.carleton.ca (Fred J Kaudel) - * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems - (K&R C does not allow initialization of "automatic" arrays or - structures). This was not use in 4d2 or previously, and the - following patch ensures that such initialization only occurs for - ANSI C compilers (Note that K&R C compilers need to explicitly - assign the values). - -Sat Dec 18 23:55:30 1993 (jaffer at jacal) - - * scm.1 scm.doc (FEATURES): improved and updated manual page. - - * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read - as ( and ) in forms. - -Wed Dec 8 23:13:09 1993 (jaffer at jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array fixes and functions. - -Tue Dec 7 00:44:23 1993 (jaffer at jacal) - - * dynl.c (dld_stub): removed since dld is working better on Linux. - -Wed Dec 1 15:27:44 1993 (jaffer at jacal) - - * scm.h (SNAME): explicit cast added to get rid of compiler - warnings. - - From: bh@anarres.CS.Berkeley.EDU (Brian Harvey) - * repl.c (repl) output newlines when more than one form on a line - for Borland C. - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array fixes and documentation. - -Mon Nov 29 01:06:21 1993 Aubrey Jaffer (jaffer at montreux) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array functions (need documentation). - -Sun Nov 28 01:34:22 1993 (jaffer at jacal) - - * scm.h (SNAME): returns a pointer to nullstr if offset is 0. - - * subr.c eval.c (make_synt make_subr): now check that offset from - heap_org hack works for each subr. If not, 0 is used. - - * Link.scm (compile-file): compiles SCM file to object suitable - for LOAD. - - * Link.scm: initialization file created with Scheme code for - compilation and linking. LOAD now automatically loads SCM object - files. - - * dynl.c Init.scm: dynamic linking now works under DLD on Linux. - Wb, crs, and sc2 can by dynamically loaded. - -Thu Nov 25 22:58:36 1993 (jaffer at jacal) - - * sys.c (ltmpnam): return value of mktemp call tested in accord - with HP-UX documentation (returns "" on error). - - * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc) - replaced with function versions. Control-C interrupts should work - while pending input on all systems again. - -Tue Nov 23 01:18:35 1993 (jaffer at jacal) - - From: dorai@cs.rice.edu (Dorai Sitaram) - * repl.c sys.c time.c config.h: MWC (Mark Williams C) support. - -Sun Nov 7 10:58:53 1993 (jaffer at jacal) - - From: "Greg Wilson" <Greg.Wilson@cs.anu.edu.au> - * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is - #defined, ticks and tick-interrupt work like alarm and - alarm-interrupt, but with units of evaluation rather than units of - time. - -Mon Nov 1 18:47:04 1993 (jaffer at jacal) - - * unif.c (uniform-vector-ref => array-ref): integrated arrays - with uniform-vectors. Strings, vectors, and uniform-vectors - now just special case of arrays (to the user). - -Fri Oct 29 01:26:53 1993 (jaffer at jacal) - - * unif.c (rasmob tc16_array): arrays are now a smob. - -Thu Oct 28 01:21:43 1993 (jaffer at jacal) - - * sys.c repl.c (igc gc_start): GC message gives reason for GC. - -Wed Oct 27 10:03:00 1993 (jaffer at jacal) - - * config.h (SICP): flag makes (eq? '() '#f) and changes other - things in order to make SCM more compatible with Abelson and - Sussman's book. - - * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from - must_malloc would collect the tc_free_cell already allocated. - - * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT): - modified to call igc when malloc usage exceeds mtrigger (idea from - hugh@ear.MIT.EDU, Hugh Secker-Walker). - - From: Jerry D. Hedden - * pi.scm (bigpi): bignum version of pi calculator. - -Tue Oct 26 18:41:33 1993 (jaffer at jacal) - - * repl.c (room): added procedure for printing storage statistics. - -Sun Oct 24 22:40:15 1993 (jaffer at jacal) - - * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added. - * sys.c (stack_check): added. - -Sat Oct 23 00:08:30 1993 (jaffer at jacal) - - * sys.c (mallocated): added to keep track of non-heap usage. - - * sys.c (igc): fixed interrupt vulnerabilities around gc. - -Sun Oct 17 13:06:11 1993 (jaffer at jacal) - - * repl.c (exit_report): added. Prints cumulative times if - (verbose > 2). Called from free_storage(). - - * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work - again. Other annoying CR behaviour fixed. - - * time.c (init_time your_base my_base): now not reset when - restarting so timing numbers for restarting are correct. - - * scm.h (sys_protects): rearranged. - * sys.c (tmp_errp): now a statically allocated global variable, - used by init_storage and free_storage. - * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport): - now #defines (which must correspond to order of newptob calls). - -Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * README.unix configure configure.in scmconfig.h.in - mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built - using GNU autoconf. Put in scmconfig4c5.tar.gz - -Sun Oct 3 00:33:57 1993 (jaffer at jacal) - - * MANUAL (bit-count bit-position bit-set*! bit-count* - bit-invert!): (from unif.c) are now documented. - - * sys.c (fixconfig): added 3rd argument to distinguish between - setjump.h and config.h. - * setjump.h config.h: moved IN_SYS stuff from config.h to - setjump.h. - * config.h (HAVE_CONFIG_H): User config preferences now taken - from "scmconfig.h" if HAVE_CONFIG_H is defined. - * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS. - -Sat Oct 2 00:34:38 1993 (jaffer at jacal) - - From: rshouman@hermes.chpc.utexas.edu (Radey Shouman) - * unif.c repl.c: added read and write syntax for uniform vectors. - * unif.c (uniform-vector->list list->uniform-vector): created. - * time.c (time_in_msec): conditionalized for wide range of CLKTCK - values. - * config.h (BITSPERDIG POINTERS_MUNGED) - * scm.h (PTR2SCM SCM2PTR) - * scl.c (DIGSTOOBIG) - Ported SCM to Unicos, the Cray operating system. - - From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab) - * scl.c (dblprec): set from DBL_DIG, if available. - -Fri Oct 1 21:43:58 1993 (jaffer at jacal) - - * unif.c (bit-position): now returns #f when item is not found. - Now returns #f when 3rd argument is length of 2nd argument - (instead of error). - -Fri Sep 24 14:30:47 1993 (jaffer at jacal) - - * sys.c (free_storage): fixed bug where growth_mon was being - called after the port cell had been freed. gc_end now also - called at end. - -Tue Sep 21 23:46:05 1993 (jaffer at jacal) - - * Init.scm scm.c: Restored old command line behaviour (loading all - command line arguments) for case when first command line argument - does not have leading `-'. - - * sys.c (mode_bits): abstracted from open_file and mksfpt. - - * scm.h (*FPORTP): series of predicates added for operations which - only work on some fports. - - * sys.c crs.c: ungetc removed from ptobfuns structure and - soft-ports. - -Mon Sep 20 23:53:25 1993 (jaffer at jacal) - - * sys.c (make-soft-port): Soft-ports added, allowing Scheme - i/o extensions. - -Sun Sep 19 22:55:28 1993 (jaffer at jacal) - - * 4c4: released. - * Init.scm scm.c scm.1: command line proccessing totally - rewritten. Thanks to Scott Schwartz - <schwartz@groucho.cs.psu.edu> for help with this. - -Mon Sep 13 21:45:52 1993 (jaffer at jacal) - - From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow) - * scl.c (add1): finally a way to fool optimizing gcc to not use - extra precision registers. - -Sun Sep 12 18:46:02 1993 (jaffer at jacal) - - * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS. - * config.h: moved flags to top per suggestions from Bryan - O'Sullivan (bos@scrg.cs.tcd.ie). - -Fri Sep 10 11:42:27 1993 (jaffer at jacal) - - * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values - returned by SCM program. - -Thu Sep 9 13:09:28 1993 Aubrey Jaffer (jaffer at camelot) - - From: Vincent Manis <manis@cs.ubc.ca> - * sys.c (stwrite init_types add_final): fixed declarations. - -Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * README: changed the build and installation instructions to bring - them up to date with reality. - -Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * Wrote autoconf script to support GNU Autoconf configuration - to make scm easier to build. - - * Created Makefile.in; a radical overhaul of Makefile to remove - some of the brokenness and allow cross-compilation and use of - autoconf. - -Sat Sep 4 23:00:49 1993 (jaffer at jacal) - - * 4c3: released. - * sys.c (grow_throw): removed use of memset for SPARC machines. - -Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * time.c: added SVR4 to the list of LACK_FTIME systems, because - most all SVR4 BSD-compatibility stuff is a total mess. - - * config.h: changed definition of STDC_HEADERS so it does the - Right Thing on systems which run GCC but don't have header files - with prototypes. - - * makefile.unix: added a note for SVR4 users. - -Tue Aug 31 18:30:53 1993 (jaffer at jacal) - - * eval.c (m_define): if verbose >= 5 warnings are issued for all - top-level redefinitions. - -Mon Aug 30 16:24:26 1993 (jaffer at jacal) - - * scm.c sys.c (finals num_finals add_final): Finalization calls - now dynamically, incrementally, defined. - -Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot) - - * 4c2: fixed declaration problems in PTOB with K&R C. - -Sun Aug 22 23:02:51 1993 (jaffer at jacal) - - * split.scm: code which directs input, output, and diagnostic - output to separate windows (using curses functions defined in - crs.c). - -Sat Aug 21 16:46:33 1993 (jaffer at jacal) - - * Init.scm (output-port-height): added if not already defined. - output-port-width also made conditional. - - * sys.c (tc16_strport): string ports created. - -Thu Aug 19 11:37:07 1993 (jaffer at jacal) - - * sys.c (init_types): freecell, floats, and bignums now have SMOB - entries. gc_sweep and gc_mark still inline codes for bignums and - floats. - - * sys.c repl.c code.doc: Ports now an extensible type. - Indirection suggested by Shen <sls@aero.org>. - -Mon Aug 16 01:20:26 1993 (jaffer at jacal) - - * crs.c: curses support created. - -Sun Aug 15 16:56:36 1993 (jaffer at jacal) - - * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0 - created. - -Fri Jun 25 01:16:31 1993 (jaffer at jacal) - - * QUICKREF: added. - -Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently - introduced transcript bug. - -Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot) - - * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF. - - * Init.scm (defmacro): now copies the results of macro expansion - in order to avoid capture of memoized code by macros like: - (defmacro f (x) `(list '= ',x ,x)). - -Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr) - - * eval.c (map for-each): now check that arguments are lists. - -Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (trace untrace): now defmacros which handle (trace) and - (untrace) as in Common Lisp. - -Wed May 5 01:17:37 1993 Aubrey Jaffer (jaffer at camelot) - - From: Roland Orre <orre@sans.kth.se> - * all: internal output functions now take SCM ports instead of - FILE* in preparation for string-ports. - -Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree) - - * makefile.unix (escm.a): created scm "ar" file and used for - dbscm. - -Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (free_storage): i++ moved out of CELL_* in response to: -From: john kozak <jkozak@cix.compulink.co.uk> -Minor bug report: around line 10 of routine "free_storage" you do calls -to CELL_UP and CELL_DOWN with arguments having side-effects: with the -PROT386switch defined in config.h these args are evaluated twice... - -Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot) - - * eval.c (IM_DEFINE): added. Internal defines are no longer - turned into LETRECS. - -Wed Apr 7 13:32:53 1993 Aubrey Jaffer (jaffer at camelot) - - Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com> - * scl.c (idbl2str): fix for bug introduced by removing +'s. - -Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot) - - * scl.c (idbl2str): now prints positivie infinity as +#.# again - (instead of #.#). - -Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux) - - * subr.c (quotient): renamed to lquotient to avoid conflict with - HP-UX 9.01. - -Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h> - * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked. - -Mon Mar 15 23:35:32 1993 Aubrey Jaffer (jaffer at camelot) - - From: jhowland@ariel.cs.trinity.edu (Dr. John E. Howland) - * scl.c (idbl2str iflo2str big2str): leading + eliminated on - output and number->string. - -Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack. - - * scm.c repl.c (exec): added. - -Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (def_err_response): now will print errobjs if they are - immediates, symbols, ports, procedures, or numbers. - -Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (repl): now gives repl_report() for initialization. - - * Init.scm (defvar): added. - - From: Roland Orre <orre@sans.kth.se> - * repl.c (lungetc): no longer calls ungetc. Fixed problem that - many systems had with ungetc on unbuffered ports (setbuf(0)). - -Thu Mar 4 13:51:12 1993 Aubrey Jaffer (jaffer at camelot) - - From: Stephen Schissler - * makefile.wcc: Watcom support added. - -Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux) - - * sys.c scm.h (dynwinds): made a sys_protect. - -Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (defmacro macroexpand macroexpand1 macro? gensym): - added. - - * repl.c (stdin): setbuf not done for __TURBOC__==1. - - * makefile.bor: now has method to build turtegr.exe. - - * eval.c (ceval): Memoizing macros now can return any legal Scheme - expression. - -Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (mkbig adjbig): now check for bignum size. - - * Init.scm: reorganized so site-specific information is at the - head. - - * repl.c (errno): changed from set-errno now returns value. - - * subr.c (intexpt): now handles bignum exponents. - - From: "David J. Fiander" <davidf@golem.waterloo.on.ca> - * time.c makefile.unix subr.c: SCO Unix and XENIX patches. - -Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT - WITH-ERROR-TO-PORT): added. - - * subr.c (ash): fixed for case (ash 2 40) where INUM arguments - make a bignum result. - - * repl.c (lreadr): \ followed by a newline in a string is ignored. - - From: Scott Schwartz <schwartz@groucho.cs.psu.edu> - * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings. - -Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (with-input-from-file with-output-to-file - with-error-to-file): now use dynamic-wind. - -Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot) - - * eval.c (ceval): fixed bug with non-memoizing macro returning an - IMP. - -Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot) - - * (current-error-port with-error-to-file): add. - -Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot) - - * time.c (stat): added. - - From: rnelson@wsuaix.csc.wsu.edu (roger nelson) - * dmakefile: support for DICE C on Amiga. - -Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (open-file) makes unbuffered if isatty. - - * repl.c (char-ready?) added. - -Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (logor): changed to LOGIOR to be compatible with common - Lisp. - - * eval.c (bodycheck): now checks for empty bodies. - -Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot) - - * time.c (get-universal-time decode-universal-time): now use - bignums. - -Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (mark_locations): now length argument in terms of - STACKITEM. Does both alignments in one pass. - -Mon Jan 25 12:13:40 1993 Aubrey Jaffer (jaffer at camelot) - - From: soravi@Athena.MIT.EDU - * makefile.emx: for OS/2 - -Sun Jan 24 18:46:32 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * scl.c (big2str): now faster because it divides by as many 10s as - fit in a BIGDIG. - -Sat Jan 23 00:23:53 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender): - * config.h (INUM MAKINUM): shift optimization for TURBOC. - -Fri Jan 22 00:46:58 1993 Aubrey Jaffer (jaffer at montreux) - - From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) - * unif.c (uniform-vector?): added. - -Tue Jan 19 00:27:04 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * subr.c scl.c config.h: bignum bug fixes for MSDOS. - -Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (ash lognot intlength logcount bitextract): now handle - bignums. - -Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (close_port): can now close pipes as well. - - * subr.c (adjbig normbig divide quotient): fixed more divide bugs. - - * subr.c (even? odd?): fixed problem with bignums. - -Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (divbigbig): Fixed last divide bug? - -Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot) - - * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU - regex-0.11. Documentation added to MANUAL. - -Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot) - - * patchlvl.h (SCMVERSION): moved from config.h. - - * scl.c (product): fixed missing {} bug. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c (lmin lmax) bignum versions. - -Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot) - - * released scm4b0. - - * subr.c: fixed bignum bugs found by jacal. - - * code cleanup. - - From: HEDDEN@esdsdf.dnet.ge.com - * subr.c (lgcd quotent modulo lremainder): Bignum versions. - * subr.c (divbigbig): new version. - -Sun Jan 3 00:29:35 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * Re-port to BorlandC v2.0 - - * sys.c (must_realloc): added - - * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of - sizeof(long)/sizeof(BIGDIG). - -Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot) - - From: Scott Schwartz <schwartz@groucho.cs.psu.edu> - * rgx.c: created SCM interface to regex and regexp routines. - - From: HEDDEN@esdsdf.dnet.ge.com - * subr.c scl.c: Now just one mulbigbig and addbigbig routine. - - from: soravi@Athena.MIT.EDU - * README: directions for compiling SCM under OS/2 2.0. - -Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (tc7_subr_2x): eliminated. All comparison subrs now - rpsubrs. - - * scm.h: Changed SUBR numbers. This improves HP-UX interpretation - speed (why?). - - * eval.c (PURE_FUNCTIONAL): removed. Can now be done in - initialization code. - - * eval.c (tc7_rpsubr): added type for transitive comparison - operators. Suprisingly, this slows down (pi 100 5). - -Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot) - - * subr.c (logand logor logxor lognot ash logcount integer-length - bit-extract): added. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c: lots more numeric improvements and code reductions. - -Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs. - -Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot) - - * subr.c scl.c: most arithmetic operations will now return - bignums. - - * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added. - - * sys.c (object-hash object-unhash): now use bignums. - - * scl.c (big2str istr2int): bignum i/o implemented. - - * unif.c: subr2s were incorrectly initialized as lsubr2s. - -Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (ceval): added unmemocar calls to error handling when - possible. - - * scl.c (idbl2str): added back NAN and infinity support. - - * eval.c (syntax_mem): replaced with individual macros. - * eval.c (procedure->syntax procedure->macro - procedure->memoizing-macro): All syntactic keywords are now - tc7_symbol. User definable macros added. - * sys.c: ISYMs no longer in symhash. ISYMs cannot be read. - init_isyms merged into init_eval. - -Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot) - - * makefile.unix (check): now exits with error code. - - * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval. - -Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot) - - * released scm4a13 - - * repl.c: longjmps now dowinds() first. - - * setjump.h: now has all setjmp related definitions. - - * Init.scm (trace untrace): use new macro system. - - * eval.c (defined? procedure->macro procedure->memoizing-macro - make_synt): macro system added. defined? uses it. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c: fixes for several transcendental functions. - -Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c sys.c: errjmp replaced with JMPBUF(rootcont). - -Sun Nov 15 01:49:00 1992 Aubrey Jaffer (jaffer at camelot) - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c (istr2int istr2flo istring2number string2number): new - versions. - -Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.scm (load): now prints out actual filename found in mesasge - ;done loading ... - -Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED - becomes WNA error. - - From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden) - * scl.c (difference divide): Now are asubrs. - - * Init.scm (*features*): fixed to correspond to SLIB conventions. - -Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot) - - * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed - to return #f. Tests added to test.scm. - -Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.h (rootcont): sysprotect added. - - From: Vincent Manis <manis@cs.ubc.ca> - * scm.h: __cplusplus prototype support. - -Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (lookupcar): now checks for UNDEFINED in local bindings - becuase LETREC inits to UNDEFINED. - - * sys.c (dynamic-wind): added. - - * config.h eval.c (ceval): CAUTIOUS mode added. - - From: hugh@ear.MIT.EDU (Hugh Secker-Walker) - * eval.c (ceval): internal defines now transformed to letrecs. - -Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (read-line read-line!): created. - -Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c (lreadparen): now tail-recursive. - - * eval.c (copy-tree eval): added. dummy_cell replaced with a - cons(obj,UNDEFINED). - -Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (set-errno!): changed to set-errno. - -Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot) - - * sys.c (must_free): must_free created. Pointers are set to 0. - It detects objects being freed twice. - -Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.c (run_scm): Now has INITS and FINALS. - - * scm.c (init_signals ignore_signals unignore_signals - restore_signals): siginterrupt() for ultix. - -Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot) - - * all: put in explicit casts to (unsigned char *) and (long) to - satisfy lint. - - * sys.c (gc): all to gc_end was during deferred interrupts, - causing problems with verbose=3 and interrupts during GC. - - * config.h(SYSCALLDEF): fixed so that test on errno occurs before - ALLOW_INTS (and possible call to user code). - -Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (syntax_mem): removed gratuitous cons. - - * eval.c repl.c scm.h: Reduced static string use. Added peephole - optimizations for AND and OR. - - From: hugh@ear.MIT.EDU (Hugh Secker-Walker) - * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized - so that syntax checks are done only once. Interpreter is now - smaller and faster and uses less stack space. Modifications to - code are now made under DEFER_INTS as they always should have - been. - -Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan) - - * scl.c subr.c scm.h config.h: Started adding bignum code. - -Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (restart): added. - - * sys.c (freeall): finished. - - * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to - distinguish between non-GCable and GCable symbols. - -Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (peek_char lungetc): added workaround for TURBOC 1.0 - problem with ungetc inside SYSCALLDEF macro. - - * repl.c (iprin1): uses ttyname for #<stream ..> if available. - - * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty. - - * repl.c (isatty?): added. - - * repl.c (verbose): levels bumped up by 1. verbose == 0 means no - prompt. - - * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108. - -Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan) - - * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2). - - * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply - (>= 1 3 2). - - * makefile.unix: tar and shar files now created in subdirectory. - - * config.h time.c: Linux support added. - - * repl.c: Greatly improved VMS interrupt support. - - * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause - unnamed lets.y - - * (tc7_lsubr_2n): removed. - -Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * unif.c (bit-position): fixed; I am sure I had done these - changes before. Also corrected some error messages. - - From: campbell@redsox.bsw.com (Larry Campbell) - * scm.h subr.c sys.c (equalp): smobfuns now include equalp. - -Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk> - * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in - BorlandC. This was fixed previously as well. - - From: campbell@redsox.bsw.com (Larry Campbell) - * unif.c (vector-set-length!): was always typing to tc7_vector. - -Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan) - - * subr.c sys.c (make_vector init_storage resizuve): mallocs and - reallocs are now always > 0. - - * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1). - -Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (lreadr): now ignores first line of port if begins with "#!" - - * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n. - - * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types - rearranged. - -Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now - support dynamically added smob types. Promises moved to eval.c. - Promises and arbiters are now newsmobs. - - * makefile.unix repl.c scl.c (floprint): moved from repl.c to - scl.c. The only files which care about -DFLOATS are now scl.c, - eval.c, scm.c, and unif.c. - - * sys.c scm.h (init_storage): now uses variable num_protects - instead of #define NUM_PROTECTS. - -Tue Jul 7 00:00:57 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Ulf_Moeller@hh2.maus.de (Ulf Moeller) - * Init.scm config.h makefile.prj: support for the ATARI-ST with - Turbo C added. - -Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * unif.c (make-uniform-vector uniform-vector-set! - uniform-vector-ref): added. - -Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c code.doc: rearranged tc7 codes and added bvect, - ivect, uvect, fvect, dvect, cvect, and cclo. - - * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be - tc7_symbol. - -Sat Jun 6 22:27:40 1992 Aubrey Jaffer (jaffer at Ivan) - - From: campbell@redsox.bsw.com (Larry Campbell) - * scl.c (divide): divide by 0 and Exact-only divides of non - multiples now cause exception in RECKLESS mode. - -Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan) - - * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN - and made proportional to size of numeric types. - - From: fred@sce.carleton.ca (Fred J Kaudel) - * makefile.ast scm.c Init.scm: minor chages for ATARI ST support. - - * test.scm (test-inexact): created. - -Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - From: hugh@ear.mit.edu (Hugh Secker-Walker) - * config.h: better wording for heap allocation strategy - explanation. - -Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan) - - From S.R.Adams@ecs.southampton.ac.uk - * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid - Borland 3.0 bug. - - * sys.c (gc_sweep): missing i-=2; added when splicing out segment. - - * MANUAL time.c (get-universal-time decode-universal-time): half - hearted attempt to add these. Needs bignums. - -Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc_mark): improved tail recursivness for CONSes. - - * repl.c (growth_mon): now prints out the hplims table if - verbose>3. - - * sys.c (init_heap_seg): Serious bug in growing hplims fixed. - num_heap_segs eliminated; hplims are realloced whenever grown. - -Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train) - - * config.h sys.c (alloc_some_heap expmem): expmem captures - whether the INIT_HEAP_SIZE allocation was successful. If so, - alloc_some_heap uses exponential heap allocation instead of - HEAP_SEG_SIZE. - -Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments - are now freed. - - * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and - R3RS functions put into sc2.c. - -Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (ignore_interrupts unignore_interrupts): added for - system, edt$edit, and popen to use. - - * repl.c (lwrite display newline write_char): Close pipe if EPIPE. - - * repl.c (file_set_position): now errs on ESPIPE. - - * scm.c (SIGPIPE): now ignored (errs come back as EPIPE). - -Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk> - * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified. - -Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan) - - From: hugh@ear.mit.edu (Hugh Secker-Walker) - * Init.scm (last-pair append!): last-pair is faster version. - Append! corrected for null first arg. (getenv "HOME") now gets - a "/" added if not present. - - * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE. - - * README: setting environment variables corrected. - - * subr.c (length): error message now has arg if not a list. - - * sys.c (open-pipe): now turns off interrupts before forking. - - * scl.c (lsystem): now turns off interrupts before forking. - - * scm.c (ignore_signals): created. - -Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in - terms of current-input-port and current-output-port. Bug in - open-input-pipe and open-output-pipe fixed. - - * sys.c repl.c (current-input-port current-output-port): moved - from sys.c to repl.c. set-current-input-port and - set-current-output-port added to repl.c. - -Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h: (PATCHLEVEL): released scm4a1. - - * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h. - - * scm.c (alrm_signal int_signal): now save and restore errno so - SYSCALL will work correctly across interrupts. - -Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h: (PATCHLEVEL): released scm4a0. - - * repl.c (lread): tok_buf now local to each invocation of read. - This makes READ interruptable and reentrant. - - * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created. - - * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c - - * repl.c (lfwrite): now emulated for VMS. - - * repl.c scl.c (num_buf): now local to all routines that use it. - - * time.h: created by moving time functions from repl.c. Read and - write functions were moved from sys.c to repl.c. - - * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally - rewritten. SIGALRM and SIGINT now execute at interrupt level. - Interrupts deferred only for protected code sections, not for - reads and writes. - - * sys.c repl.c (SYSCALL): created to reexecute system calls - interrupted (EINTR) by SIGALRM and SIGINT. - - * sys.c scl.c (flo0): 0.0 is now always flo0. - - * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This - required shadowing putc, fputs, fwrite, and getc with lputc, - lputs, lfwrite, and lgetc. - -Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan) - - From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden) - * scl.c (eqp lessp greaterp lesseqp greatereqp): - Comparisons with inexact numbers was not being performed - correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was - missing was a line x=y; in the inexact comparison sections of - lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I - modified these routines and eqp() to allow for mixed arithmetic - types. - -Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and - tc16_bigneg. SMOBS reordered. tc16_record added. - - * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter): - added. tc16_arbiter added. - -Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h (TEMPTEMPLATE): created in config.h. - - * scm.h: removed long aliases for C versions of Scheme functions. - - * sys.c eval.c scm.h: (delay force makprom): added. Also added - tc16_promise data type. - - * Init.scm (trace untrace): added autoloads and read macros. - - From: T. Kurt Bond, tkb@mtnet2.wvnet.edu - * sys.c (template): correct template for VMS. - -Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h Init.scm (open-file open-pipe): created and - expressed other open functions in terms of. Bracketed all i/o - system calls with DEFER and ALLOW _SIGINTS. - -Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c MANUAL (#.): read macro syntax added. Balanced comments - also documented. - -Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (iprin1): changed printed representation for unreadable - objects from #[...] to #<...>. - - From: brh@aquila.ahse.cdc.com (brian r hanson x6009): - * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on - nosve. - -Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan) - - * Released scm3c13 - - * code.doc: corrected some minor inconsistencies and added a - section "To add a package of new procedures to scm". - -Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.scm: now loads <program-name>_INIT_PATH when <program-name> - is not "SCM". - - * config.h (PTR_LT): (x < y) => ((x) < (y)) - -Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan) - - * Released scm3c12. - - * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM - type. - -Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan) - - * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added - DEFINED? to ceval conditional on SYNTAX_EXTENSIONS. - - From: Andrew Wilcox <andrew@astro.psu.edu> - * makefile.unix scm.c (main init_scm display_banner init_signals - restore_signals run_scm): RTL support. - -Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan) - - * subr.c (make-string): now checks for ARG1 >= 0. - -Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 12 - - * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL, - jcal or jacal. - - * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported. - - * gc_mark gc: no longer assume sizeof(short) == 2. - - * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8. - - From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com - * scl.c config.h repl.c: partial port to Control Data NOS/VE. - - From: fred@sce.carleton.ca (Fred J Kaudel) - * repl.c Init.scm makefile.ast: Port to Atari-ST - - * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict - with Gnu CC. - -Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (delete-file rename-file): added. - - * sys.c (chdir): now returns #f instead of error. - - * Init.scm: Calls to PROVIDED? inlined so no longer dependent on - SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported. - Support for slib1b3 added. - - * sys.c (alloc_some_heap): fixed bugs. One fix from - bowles@is.s.u-tokyo.ac.jp. - - * eval.c (ceval): fixed bug with internal (define foo bar) where - bar is a global. Put badfun2: back in for better error reporting. - - * patchlvl.h (PATCHLEVEL): 11 - -Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * config.c (INITS): comments added. - - From: T. Kurt Bond, tkb@mtnet2.wvnet.edu - * VMSGCC.COM VMSMAKE.COM: now take arguments. - - From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> - * makefile.aztec repl.c: Aztec C (makefile) port. - -Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc init_storage stack_size): stack_size now of type - sizet. init_storage no longer uses it. gc() now uses it instead - of pointer to local. This fixes bug with gcc -O. - - * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above - fix. - -Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (real-part): added. - -Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan) - - From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> - * scl.c repl.c scm.c config.c: Port for AMIGA - - * scm.h (REALP): fixed for SINGLES not defined. - -Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 8 released. - - * README: added hints for EDITING SCHEME CODE. - - * repl.c (SIGRETTYPE): now int for __TURBOC__. - - * makefile.tur makefile.djg: created. - - * config.h: DJGPP (__GO32__) support added. - - * scm.h (memv): definition added. - -Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c makefile.* (main): INITS added. - - * scl.c: fixed ASSERT statements with mismatched ARGn and - arguments. - -Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train) - - * sys.c (cons cons2 cons2r): added fix for gcc -O bug. - - * repl.c (LACK_FTIME LACK_TIMES): more messing with these. - - * sys.c config.o (HAVE_PIPE): created. - - * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__. - Needed for DJGCC. - - * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly - rather than STDC_INCLUDES. - - * makefile.unix (subr.o): explicit compilation line added. - - * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries. - -Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (apply): added check for number of args to closures. - -Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 7 - - * sys.c (chdir): THINK_C doesn't support; - - * repl.c: SVR2 needs <time.h> instead of <sys/time.h> - - * repl.c: SVR2 needs LACK_FTIME - - * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME. - -Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - * sys.c (intern sysintern): made strings and hash unsigned. Fixed - bug with characters > 128 in symbols. - - * scl.c (eqv? memv assv): created if FLOATS is #defined. From - boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza). - -Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 4 - - * sys.c (gc_sweep): usaage of pclose() now conditional on unix. - - * MANUAL (chdir): documented. - - from T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>: - - * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h> - to get the link-time attributes for the errno variable to match - those the VMS C run-time library expects (it makes errno a - preprocessor define so that the variable that the compiler sees - has a special form that the assember then interprets), so if it is - VMS and __GNUC__ is defined <errno.h> needs included. - - * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to - setjump and longjump. The VMS linker is case-indifferent. VMS GNU - C mangles variable names that have upper case letters in them to - preserve their uniqueness. - - * sys.c (iprint iprin1): Now inline putc loops instead of calls to - fwrite for VMS. The VMS `fwrite' has been enhanced to work with - VMS's Record Management Sevice, RMS. Part of this enhancement is - to treat each call to `fwrite' as producing a separate record. - This works fine if you are writing to a stream_LF file or an - actual terminal screen, but if you are writing to a file that has - implied carriage control (such as a batch log file, or a mailbox - used for subprocess communication), which is a more common file - organization for RMS, each call to `fwrite' has a newline appended - to it. This causes much of the output to be incorrectly split - across lines. - - * vmsgcc.com: created. - -Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 3 released. - - * Init.scm (rev2-procedures): all now supported. - - * Init.scm sys.c MANUAL (flush): flush changed to force-output to - be compatible with Common Lisp. - - * sys.c (chdir): added. - -Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 2 - - * repl.c (set-errno! perror): added. - - * sys.c (gc): FLUSH_REGISTER_WINDOWS call added. - - * sys.c (open-input-pipe open-output-pipe close-pipe): added. - -Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 1 - - * sys.c (flush): added. - - * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60. - - * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda, - honda@csl.SONY.co.jp, support for Macintosh running Think C. - -Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (str2flo): fixed parsing of -1-i. - - * repl.c (repl_driver): from jjc@jclark.com, now checks that - s_response is non-NULL before INTERNing. - - * subr.c (equal): Now correct for inexacts. Need to do eqv. - - * scm.h (REALPART): fixed pixel C compiler bug with doubles inside - `?' conditionals. - - * scl.c (zerop): now checks imaginary half of complex number. - -Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan) - - * version scm3c0 - - * documentation: changed revised^3.99 to revised^4. - - * example.scm: created from Scheme^4 spec. - - * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float - optimizations. - - * Init.scm (ed): defined. - - * repl.c (def_err_response): UNDEFINED objects don't print out. - -Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (vms-debug): now returns UNSPECIFIED. - - * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT. - - * repl.c (err_ctrl_c):now clears sig_pending. - -Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan) - - * config.h: removed #ifdef sparc #define STDC_HEADERS - - * makefile.bor: added extra '\' to filepath. - - * repl.c (everr): fixed bug with ARGx. - - * repl.c (errmsgs def_err_response): cleaned up error messages. - -Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan) - - * released scm3b7 - -Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 6 - - * sys.c (idbl2str): tests for Not-a-Number and Infinity added. - - * repl.c scm.h: response system rewritten and integrated with - error system. - - * scl.c (/): now returns inexacts if integer arguments do not - divide evenly. - -Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan) - - * makefile.unix: can now make float (scm) and integer-only (escm) - versions in same directory. - - * repl.c (*sigint-response* *arithmetic-response* restart-repl): - responses for signals added. - - * scl.c (lmin lmax sum difference product divide expt exp log): - now take mixed types. expt available in non-FLOATS compilation. - - * repl.c (get-decoded-time): added. Includes and time functions - reorganized. - - * sys.c (object-hash object-unhash): added. - -Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan) - - * repl.c Init.scm (*features*): moved constant features into - Init.scm. Moved tests for numeric features to slib/require.scm. - - * release scm3b1. - - * config.h (ANSI_INCLUDES): redid include files. - - * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c. - -Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan) - - * release scm3a13. - - * patchlvl.h (PATCHLEVEL): 13 - - * Init.scm: "vicinity.scm" changed to "require.scm" - -Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan) - - * test.scm: test of redefining built-in symbol and extra ')' - removed. - - * scm.doc makefile.unix: scm.doc created from scm.1 in - makefile.unix. - - * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put - in from comp.sources.reviewed in order to let VMS have full - continuations. VMSBUILD.COM is a compile script. - -Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c(sleep): removed; not supported by MSC (although could be - written). - - * scm.h config.h (size_t): moved to config.h. - - * sys.c (f_getc): -> lgetc for vax, getc otherwise. - - * patchlvl.h (PATCHLEVEL): 12 - -Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c(sleep): created. - - * repl.c(internal-time-units-per-second get=internal-run-time): - created - - * repl.c: created from scm.c (shuffled around lots of functions). - -Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c config.h (char-code-limit most-positive-fixnum - most-negative-fixnum): created. - -Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (software-type); created. - - * scm.c config.h (terms, list-file, library-vicinity, - program-vicinity, user-vicinity, make-vicinity, sub-vicinity): - moved to Init.scm and library. - - * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH. - - * Init.scm: created - -Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - * all: changed declarations to size_t where appropriate. scm.h - test preprocessor flag _SIZE_T to determine if already declared. - size_t should greatly enhance portability to Macintosh and other - machines. - -Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (tmpnam): support for mktemp added. - -Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train) - - * scm.c (implementation-vicinity): added. (program-vicinity) now - returns undefined if called not within a load. - - * sys.c (call-with-io-file): removed. - - * scm.c (tmpnam): added. - - * scm.c config.h (tmporary-vicinity): removed. - -Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan) - - * subr.c scm.h (remainder): renamed to lremainder to avoid - conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk). - -Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (program-arguments load): program-arguments created. - - * scm.c (getenv): added getenv and used for program-vicinity and - library-vicinity. - - * scm.c (program-vicinity): fixed if load_name is NULL. - - * scl.c config.h (substring-move-left! substring-move-right!): - added under STR_EXTENSIONS flag. - -Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan) - - * Sending scm3a to comp.sources.reviewed - - * scm.c (main): prints out feature list at startup. - - * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for - floats. - - * scl.c (sum difference divide product): moved to scl.c and - now work for floats. - - * all: all masks with low bits explicity cast to (int). - -Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo - iflo2str idbl2str): number I/O and conversion to strings rewritten. - - * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from - Craig Lawson). - - * added QuickC support from Craig Lawson. - -Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan) - - * config.h: #ifdef pyr added. - - * scm.c MANUAL: vicinity functions added. - -Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c sys.c: float functions added. - - * Documentation reorganized according to comp.sources.reviewed - guidelines. - - * sys.c config.h (open_input_file open_output_file open_rw_file): - file mode string moved to defines in config.h - -Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h (EBCDIC ASCII) moved to config.h - - * subr.c config.h (BADIVSGNS) moved to config.h - - * scm.h config.h (SRS) moved to config.h - -Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan) - - * all: started adding comp.sources.reviewed corrections and - suggestions. - - * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner. - - * subr.c sys.c: read_integer removed. istring2number created. - lread and string2number now both use istring2number. - -Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan) - - * VERSION scm2e sent to comp.sources.reviewed - - * public.lic: renamed COPYING. - - * scm.c (gc_status): gc_status renamed prolixity. Now returns old - value of verbose. Can take 0 arguments. - - * sys.c (lreadr): added #| common lisp style |# balanced comments. - - * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to - become OP**PORTP. - - * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of - port cells. - -Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (stack_start_ptr, repl_driver, main, err functions): - exits removed from all err functions. all escapes through - repl_driver. - - * scm.c README (verbose): Now has graded verbosity. - - * scm.c README (quit): Now takes optional argument which is return - value. - -Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan) - - * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to - create IXSYMs (immediate extension syms) to allow more than 15 - special forms. ILOCs now work with up to 32767 in one environment - frame. Dispatch is slightly faster for ILOCs in function position. - ICHRs can be up to 24 bits. - -Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR - for some datatypes. - -Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan) - - * patch1 MESSAGE SENT. - - * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed - order evaluation bug when growing tok_buf. - -Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm2d RELEASED - - * sys.c (closure) no longer calls ilength (ECONS problem). Added - ASSERT before call to closure in eval. - -Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (error): created. - -Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan) - - * utils.scm: created. - - * makefile (name8s): code from dmason works in makefile. - - * eval.c (evalcar): fixed errobj on (else 3 4) error. - Inlined function application in (cond ((foo => fun))). - - * sys.c (lprin1): change looped putcs to fwrite. - -Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (lreadr): fixed assert for "eof in string". - - * subr.c (lgcd): changed to work with borland C. - - * eval.c (eval): added checks to LAMBDA and LET. - - * eval.c (apply): now checks for null arg1 in lsubr. - -Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph) - - * config.h scm.h (SCMPTR): created to correct address arithmetic - on stack bounds under Borland C++. Borland C++ now runs scm2c. - -Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (open_io_file, cw_io_file, file_position, file_set_pos, - read_to_str) created (IO_EXTENSIONS) - - * config.h (IO_EXTENSIONS): defined - - * sys.c scm.c: lprin1f changed to iprin1 - -Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to - for(i = alen;0 < --i;). - This fixed b_pos and v_pos mapping to the same symbol. - -Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu) - - * released scm2b - -Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan) - - * all files: eliminated types tc7_subr_2n and tc7_subr_2xn. - Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls - can be checked for number of arguments. - -Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan) - - * code.doc: cleaned up. - -Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (ceval): fixed nasty tail recursion bug at carloop:. - - * scm.c (everr): still fixing error reporting. - - * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side - effect special forms and functions. - - * subr.c (substring): now allows first index to be equal to length - of string - - * sys.c (lprin1f): dispatches on TYP16 of smobs. - - * scm.h: fixed typo in unused function defs. - -Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu) - - * scm2a released: too many changes to record. See code.doc. - -Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm.h: types reformatted (TYP6 -> TYP7). - - * eval.c (ceval): Now dispatch directly on ISYMs in ceval. - -Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid) - - * sys.c: #include <malloc.h> not done for VMS - -Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm.c scl.c: added unsigned declarations to some char * - definitions in order to fix characters having negative codes. - - * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to - long so that their calls don't have to. Changing MAKICHR fixed - problem in scl.c (string2list) on IBMPC. - - * subr.c (quotient): support for `/' reintroduced; required by - r3.99rs but not IEEE. - - * subr.c (char functions): added isascii tests for - char-alphabetic, char-numeric?, char-whitespace?, - char-upper-case?, and char-lower-case?. Added test against - char_code_limit to int2char. - - * subr.c (s_char_alphap): is subr_1 not lsubr. - - * test.scm: added tests for char-alphabetic, char-numeric?, - char-whitespace?, char-upper-case?, and char-lower-case?. - - * sys.c: most `return;'s eliminated to reduce warning messages. - Substituted breaks and reordered switch and if clauses. - -Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm1-2: released. - - * sys.c (read-char peek-char) added code for EOF. - - * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O - tests added. - - * sys.c (I/O functions) now check for input and output ports - rather than just ports. - - * sys.c (lprin1f): occurences of stdout changed to f. Newlines - after printing port removed. - -Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid) - - * subr.c (quotient): support for `/' removed; not required. - - * scm.c (wta): message for OUTOFRANGE fixed. - -Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid) - - * eval.c (apply): added checks for number of arguments. - - * scm.h (CHECK_SIGINT): checks for blocked SIGINT. - - * sys.c (lprin1): added blocking and testing for SIGINT so that - output won't hang on VMS. - - * scm.c (repl): added fflush call. - - * scm.c (err_head, wta): added fflush calls to error routines so - that error message come out in proper order. - diff --git a/libguile/DYNAMIC-LINKING b/libguile/DYNAMIC-LINKING deleted file mode 100644 index cb7134318..000000000 --- a/libguile/DYNAMIC-LINKING +++ /dev/null @@ -1,95 +0,0 @@ -Random notes about dynamic linking for Guile. I will update this file -as I go along. Comments are very welcome. I can be reached at -mvo@zagadka.ping.de (Marius Vollmer). - -The dynamic linking support is mostly untested. I can't test it -because I don't have all the different platforms, of course. Please -try it out. - -To enable support for dynamic linking in libguile, give the - - --enable-dynamic-linking - -option to configure. It is disabled by default because it will -probably cause lots of problems in its present state. Currently there -is support for -ldld, -ldl, HP-UX (and VMS, but not really). - -Files affected: - - dynl* new - configure.in add --enable-dynamic-linking option and checking for - system dependencies - Makefile.am include dynl* in build and dist. - init.c initialize dynamic linking support - -Here is my plan with indications of progress. - -- port "dynl.c" and maybe some parts of "Link.scm" from SCM to - Guile. This should not be difficult, maybe I can even squeeze the - VMS code into the "dynl:link", "dyn:call" interface. - -* Mostly done, except VMS, and almost completely untested. The -dl - support should work, but the rest has not even been compiled. - - The code is in the "dynl*" files. "dynl.c" is the system independent - portion and includes the appropriate system dependent file, either - "dynl-dld.c", "dynl-dl.c" or "dynl-shl.c". - - I have renamed the SCM names of the functions, because they didnn't - fit very well into Guile, the semantics are the same: - - SCM name Guile name - - dynl:link dynamic-link - dynl:call dynamic-call - dynl:main-call dynamic-args-call - dynl:unlink dynamic-unlink - - I plan to generalise dynamic-call and dynamic-args-call to work with - arbitrary arguments, so these names are likely to change. - - PROBLEMS: - - When including dynlink support in libguile you need to link your - applications with additional libraries (-ldl or -ldld). How do you - communicate this to "guile" and "gh_test" for example? Some PLUGIN - magic? - - You may need to link your application in a special way to make - dynamic linking work. For example, on Linux and a statically linked - libguile.a, you need -rdynamic to make the libguile symbols - available for dynamic linking. The solution is probably to build - libguile as a shared library on the systems that support it. Does - libtool help here? Where can I find it? - - -- see how to couple dynamic linking with the module system. Dynamic - objects should have a way to specify the module they want to add - their bindings to. Extend this to statically linked parts of - guile. (i.e. posix could be put into a module and initialized on - demand) - -* Maybe it will suffice to have scm_make_gsubr, etc to honor the - current scm_top_level_lookup_closure and do all the module switching - from Scheme. - - -- use gtcltk as a test case for the above, so that TCL/Tk capabilities - can be added to guile at runtime. - -- see how G-Wrap and libffi can work together and extend dyn:call to - functions taking arbitrary arguments. Something along the lines - - (define XOpenDisplay (make-foreign-function X11-lib 'XOpenDisplay - .. whatever args ..)) - - -I have no ideas how to support the development of packages for Guile -that can be dynamically linked into a running application. Maybe -automake can be used to automate most of the issues. - -One nice thing is, however, that developers and users of Guile -packages have already installed Guile. So we might able to use Scheme -to describe and handle the build process. I would like that much more -than the arcane shell based implementations of autoconf, automake, -etc. diff --git a/libguile/Makefile.am b/libguile/Makefile.am deleted file mode 100644 index b944b49be..000000000 --- a/libguile/Makefile.am +++ /dev/null @@ -1,60 +0,0 @@ -## Process this file with Automake to create Makefile.in - -AUTOMAKE_OPTIONS = foreign - -## Check for headers in $(srcdir)/.., so that #include -## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're -## building. -INCLUDES = -I.. -I$(srcdir)/.. - -lib_LIBRARIES = libguile.a -libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \ -backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \ -error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \ -gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \ -kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \ -options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \ -read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \ -stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \ -strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \ -vectors.c version.c vports.c weaks.c _scm.h - -include_HEADERS = libguile.h - -# These are headers visible as <libguile/mumble.h>. -modincludedir = $(includedir)/@module@ -modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \ -backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \ -error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \ -gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \ -kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \ -options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \ -root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \ -stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \ -symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \ -vports.h weaks.h snarf.h - -## This file is generated at configure time. That is why it is DATA -## and not a header -- headers are included in the distribution. -modinclude_DATA = scmconfig.h - -bin_SCRIPTS = guile-snarf - -EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \ -dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs - -## FIXME: shouldn't directly generate file; instead generate temp file -## and "mv". Consider using timestamp file as well, to avoid -## unnecessary rebuilds. -libpath.h: Makefile - echo '/* generated by Makefile */' > libpath.h - echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h - echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h - echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h - -SUFFIXES = .x -.c.x: - ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ - -## Add -MG to make the .x magic work with auto-dep code. -MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) diff --git a/libguile/Makefile.in b/libguile/Makefile.in deleted file mode 100644 index 6c779f9e3..000000000 --- a/libguile/Makefile.in +++ /dev/null @@ -1,478 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = . - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -VERSION = @VERSION@ -RANLIB = @RANLIB@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -module = @module@ -CC = @CC@ -PACKAGE = @PACKAGE@ -FD_SETTER = @FD_SETTER@ - -AUTOMAKE_OPTIONS = foreign - -INCLUDES = -I.. -I$(srcdir)/.. - -lib_LIBRARIES = libguile.a -libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \ -backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \ -error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \ -gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \ -kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \ -options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \ -read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \ -stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \ -strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \ -vectors.c version.c vports.c weaks.c _scm.h - -include_HEADERS = libguile.h - -# These are headers visible as <libguile/mumble.h>. -modincludedir = $(includedir)/@module@ -modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \ -backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \ -error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \ -gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \ -kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \ -options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \ -root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \ -stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \ -symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \ -vports.h weaks.h snarf.h - -modinclude_DATA = scmconfig.h - -bin_SCRIPTS = guile-snarf - -EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \ -dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs - -SUFFIXES = .x - -MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -ACLOCAL = $(top_srcdir)/aclocal.m4 -CONFIG_HEADER_IN = scmconfig.h.in -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_HEADER = scmconfig.h -CONFIG_CLEAN_FILES = fd.h guile-snarf -LIBRARIES = $(lib_LIBRARIES) - - -DEFS = @DEFS@ -I. -I$(srcdir) -I. -CPPFLAGS = @CPPFLAGS@ -LDFLAGS = @LDFLAGS@ -LIBS = @LIBS@ -libguile_a_LIBADD = -libguile_a_OBJECTS = alist.o append.o appinit.o arbiters.o async.o \ -backtrace.o boolean.o chars.o continuations.o debug.o dynl.o dynwind.o \ -eq.o error.o eval.o extchrs.o fdsocket.o feature.o filesys.o fports.o \ -gc.o gdbint.o genio.o gsubr.o hash.o hashtab.o inet_aton.o init.o \ -ioext.o kw.o list.o load.o mallocs.o markers.o mbstrings.o numbers.o \ -objprop.o options.o pairs.o ports.o posix.o print.o procprop.o procs.o \ -ramap.o read.o root.o scmsigs.o sequences.o simpos.o smob.o socket.o \ -srcprop.o stackchk.o stacks.o stime.o strerror.o strings.o strop.o \ -strorder.o strports.o struct.o symbols.o tag.o throw.o unif.o \ -variable.o vectors.o version.o vports.o weaks.o -AR = ar -SCRIPTS = $(bin_SCRIPTS) - -CFLAGS = @CFLAGS@ -COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -LINK = $(CC) $(LDFLAGS) -o $@ -DATA = $(modinclude_DATA) - -HEADERS = $(modinclude_HEADERS) $(include_HEADERS) - -DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in acconfig.h \ -acinclude.m4 aclocal.m4 configure configure.in fd.h.in guile-snarf.in \ -scmconfig.h.in stamp-h.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -DEP_FILES = .deps/alist.P .deps/append.P .deps/appinit.P \ -.deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \ -.deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \ -.deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/extchrs.P \ -.deps/fdsocket.P .deps/feature.P .deps/filesys.P .deps/fports.P \ -.deps/gc.P .deps/gdbint.P .deps/genio.P .deps/gsubr.P .deps/hash.P \ -.deps/hashtab.P .deps/inet_aton.P .deps/init.P .deps/ioext.P .deps/kw.P \ -.deps/list.P .deps/load.P .deps/mallocs.P .deps/markers.P \ -.deps/mbstrings.P .deps/numbers.P .deps/objprop.P .deps/options.P \ -.deps/pairs.P .deps/ports.P .deps/posix.P .deps/print.P \ -.deps/procprop.P .deps/procs.P .deps/ramap.P .deps/read.P .deps/root.P \ -.deps/scmsigs.P .deps/sequences.P .deps/simpos.P .deps/smob.P \ -.deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \ -.deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \ -.deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \ -.deps/tag.P .deps/throw.P .deps/unif.P .deps/variable.P .deps/vectors.P \ -.deps/version.P .deps/vports.P .deps/weaks.P -SOURCES = $(libguile_a_SOURCES) -OBJECTS = $(libguile_a_OBJECTS) - -default: all - -.SUFFIXES: -.SUFFIXES: .c .o .x -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -$(srcdir)/aclocal.m4: configure.in acinclude.m4 - cd $(srcdir) && aclocal - -config.status: configure - $(SHELL) ./config.status --recheck -$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) - cd $(srcdir) && autoconf - -$(CONFIG_HEADER): stamp-h -stamp-h: $(CONFIG_HEADER_IN) $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES= CONFIG_HEADERS=$(CONFIG_HEADER) \ - $(SHELL) ./config.status - @echo timestamp > stamp-h -$(srcdir)/$(CONFIG_HEADER_IN): stamp-h.in -$(srcdir)/stamp-h.in: $(top_srcdir)/configure.in $(ACLOCAL) acconfig.h - cd $(top_srcdir) && autoheader - echo timestamp > $(srcdir)/stamp-h.in - -mostlyclean-hdr: - -clean-hdr: - -distclean-hdr: - rm -f $(CONFIG_HEADER) - -maintainer-clean-hdr: -fd.h: $(top_builddir)/config.status fd.h.in - cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status -guile-snarf: $(top_builddir)/config.status guile-snarf.in - cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status - -mostlyclean-libLIBRARIES: - -clean-libLIBRARIES: - test -z "$(lib_LIBRARIES)" || rm -f $(lib_LIBRARIES) - -distclean-libLIBRARIES: - -maintainer-clean-libLIBRARIES: - -install-libLIBRARIES: $(lib_LIBRARIES) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(libdir) - list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(libdir)/$$p"; \ - $(INSTALL_DATA) $$p $(libdir)/$$p; \ - else :; fi; \ - done - $(POST_INSTALL) - @list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(RANLIB) $(libdir)/$$p"; \ - $(RANLIB) $(libdir)/$$p; \ - else :; fi; \ - done - -uninstall-libLIBRARIES: - list="$(lib_LIBRARIES)"; for p in $$list; do \ - rm -f $(libdir)/$$p; \ - done - -.c.o: - $(COMPILE) -c $< - -mostlyclean-compile: - rm -f *.o core - -clean-compile: - -distclean-compile: - rm -f *.tab.c - -maintainer-clean-compile: -$(libguile_a_OBJECTS): scmconfig.h - -libguile.a: $(libguile_a_OBJECTS) $(libguile_a_DEPENDENCIES) - rm -f libguile.a - $(AR) cru libguile.a $(libguile_a_OBJECTS) $(libguile_a_LIBADD) - $(RANLIB) libguile.a - -install-binSCRIPTS: $(bin_SCRIPTS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(bindir) - @list="$(bin_SCRIPTS)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`"; \ - $(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`; \ - else if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`"; \ - $(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`; \ - else :; fi; fi; \ - done - -uninstall-binSCRIPTS: - list="$(bin_SCRIPTS)"; for p in $$list; do \ - rm -f $(bindir)/`echo $$p|sed '$(transform)'`; \ - done - -install-modincludeDATA: $(modinclude_DATA) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(modincludedir) - @list="$(modinclude_DATA)"; for p in $$list; do \ - if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \ - else if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $$p $(modincludedir)/$$p; \ - fi; fi; \ - done - -uninstall-modincludeDATA: - list="$(modinclude_DATA)"; for p in $$list; do \ - rm -f $(modincludedir)/$$p; \ - done - -install-modincludeHEADERS: $(modinclude_HEADERS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(modincludedir) - @list="$(modinclude_HEADERS)"; for p in $$list; do \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \ - done - -uninstall-modincludeHEADERS: - list="$(modinclude_HEADERS)"; for p in $$list; do \ - rm -f $(modincludedir)/$$p; \ - done - -install-includeHEADERS: $(include_HEADERS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(includedir) - @list="$(include_HEADERS)"; for p in $$list; do \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p; \ - done - -uninstall-includeHEADERS: - list="$(include_HEADERS)"; for p in $$list; do \ - rm -f $(includedir)/$$p; \ - done - -tags: TAGS - -ID: $(HEADERS) $(SOURCES) - here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS) - -TAGS: $(HEADERS) $(SOURCES) scmconfig.h.in $(TAGS_DEPENDENCIES) - tags=; \ - here=`pwd`; \ - list="$(SUBDIRS)"; for subdir in $$list; do \ - test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \ - done; \ - test -z "$(ETAGS_ARGS)scmconfig.h.in$(SOURCES)$(HEADERS)$$tags" \ - || cd $(srcdir) && etags $(ETAGS_ARGS) $$tags scmconfig.h.in $(SOURCES) $(HEADERS) -o $$here/TAGS - -mostlyclean-tags: - -clean-tags: - -distclean-tags: - rm -f TAGS ID - -maintainer-clean-tags: - -distdir = $(PACKAGE)-$(VERSION) -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - rm -rf $(distdir) - $(TAR) zxf $(distdir).tar.gz - mkdir $(distdir)/=build - mkdir $(distdir)/=inst - dc_install_base=`cd $(distdir)/=inst && pwd`; \ - cd $(distdir)/=build \ - && ../configure --srcdir=.. --prefix=$$dc_install_base \ - && $(MAKE) \ - && $(MAKE) dvi \ - && $(MAKE) check \ - && $(MAKE) install \ - && $(MAKE) installcheck \ - && $(MAKE) dist - rm -rf $(distdir) - @echo "========================"; \ - echo "$(distdir).tar.gz is ready for distribution"; \ - echo "========================" -dist: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -dist-all: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -distdir: $(DISTFILES) - rm -rf $(distdir) - mkdir $(distdir) - -chmod 755 $(distdir) - here=`pwd`; distdir=`cd $(distdir) && pwd` \ - && cd $(srcdir) \ - && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign - $(mkinstalldirs) $(distdir)/PLUGIN - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done -.deps/.P: - test -d .deps || mkdir .deps - echo > $@ - --include $(DEP_FILES) -$(DEP_FILES): .deps/.P - -mostlyclean-depend: - -clean-depend: - -distclean-depend: - -maintainer-clean-depend: - rm -rf .deps - -.deps/%.P: $(srcdir)/%.c - @echo "Computing dependencies for $<..." - @o='o'; \ - test -n "$o" && o='$$o'; \ - $(MKDEP) $< | sed "s/^\(.*\)\.o:/\1.$$o \1.l$$o:/" > $@ -info: -dvi: -check: all - $(MAKE) -installcheck: -install-exec: install-libLIBRARIES install-binSCRIPTS - $(NORMAL_INSTALL) - -install-data: install-modincludeDATA install-modincludeHEADERS install-includeHEADERS - $(NORMAL_INSTALL) - -install: install-exec install-data all - @: - -uninstall: uninstall-libLIBRARIES uninstall-binSCRIPTS uninstall-modincludeDATA uninstall-modincludeHEADERS uninstall-includeHEADERS - -all: $(LIBRARIES) $(SCRIPTS) $(DATA) $(HEADERS) Makefile scmconfig.h - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: - $(mkinstalldirs) $(libdir) $(bindir) $(modincludedir) $(modincludedir) \ - $(includedir) - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean: mostlyclean-hdr mostlyclean-libLIBRARIES \ - mostlyclean-compile mostlyclean-tags mostlyclean-depend \ - mostlyclean-generic - -clean: clean-hdr clean-libLIBRARIES clean-compile clean-tags \ - clean-depend clean-generic mostlyclean - -distclean: distclean-hdr distclean-libLIBRARIES distclean-compile \ - distclean-tags distclean-depend distclean-generic clean - rm -f config.status - -maintainer-clean: maintainer-clean-hdr maintainer-clean-libLIBRARIES \ - maintainer-clean-compile maintainer-clean-tags \ - maintainer-clean-depend maintainer-clean-generic \ - distclean - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - rm -f config.status - -.PHONY: default mostlyclean-hdr distclean-hdr clean-hdr \ -maintainer-clean-hdr mostlyclean-libLIBRARIES distclean-libLIBRARIES \ -clean-libLIBRARIES maintainer-clean-libLIBRARIES uninstall-libLIBRARIES \ -install-libLIBRARIES mostlyclean-compile distclean-compile \ -clean-compile maintainer-clean-compile uninstall-binSCRIPTS \ -install-binSCRIPTS uninstall-modincludeDATA install-modincludeDATA \ -uninstall-modincludeHEADERS install-modincludeHEADERS \ -uninstall-includeHEADERS install-includeHEADERS tags mostlyclean-tags \ -distclean-tags clean-tags maintainer-clean-tags distdir \ -mostlyclean-depend distclean-depend clean-depend \ -maintainer-clean-depend info dvi installcheck install-exec install-data \ -install uninstall all installdirs mostlyclean-generic distclean-generic \ -clean-generic maintainer-clean-generic clean mostlyclean distclean \ -maintainer-clean - - -libpath.h: Makefile - echo '/* generated by Makefile */' > libpath.h - echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h - echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h - echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h -.c.x: - ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/libguile/__scm.h b/libguile/__scm.h deleted file mode 100644 index 22c2eaa38..000000000 --- a/libguile/__scm.h +++ /dev/null @@ -1,432 +0,0 @@ -/* classes: h_files */ - -#ifndef __SCMH -#define __SCMH -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* {Supported Options} - * - * These may be defined or undefined. - */ - -/* If the compile FLAG `CAUTIOUS' is #defined then the number of - * arguments is always checked for application of closures. If the - * compile FLAG `RECKLESS' is #defined then they are not checked. - * Otherwise, number of argument checks for closures are made only when - * the function position (whose value is the closure) of a combination is - * not an ILOC or GLOC. When the function position of a combination is a - * symbol it will be checked only the first time it is evaluated because - * it will then be replaced with an ILOC or GLOC. - */ -#undef RECKLESS -#define CAUTIOUS - -/* After looking up a local for the first time, rewrite the - * code graph, caching its position. - */ -#define MEMOIZE_LOCALS - -/* All the number support there is. - */ -#define SCM_FLOATS -#define BIGNUMS - -/* GC should relinquish empty cons-pair arenas. - */ -#define GC_FREE_SEGMENTS - -/* Provide a scheme-accessible count-down timer that - * generates a pseudo-interrupt. - */ -#define TICKS - - -/* Use engineering notation when converting numbers strings? - */ -#undef ENGNOT - -/* Include support for uniform arrays? - * - * Possibly some of the initialization code depends on this - * being defined, but that is a bug and should be fixed. - */ -#define ARRAYS - -#undef SCM_CAREFUL_INTS - -/* {Unsupported Options} - * - * These must be defined as given here. - */ - - -#define CCLO - -/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We - have horrible plans for their unification. */ -#undef SICP - - - -/* Random options (not yet supported or in final form). */ - -#define STACK_CHECKING -#undef NO_CEVAL_STACK_CHECKING -#undef LONGLONGS - -/* Some auto-generated .h files contain unused prototypes - * that need these typedefs. - */ -typedef long long_long; -typedef unsigned long ulong_long; - - - -/* What did the configure script discover about the outside world? */ -#include "libguile/scmconfig.h" - - -/* Write prototype declarations like this: - int foo SCM_P ((int a, int b)); - At definitions, use K&R style declarations, but make sure there's a - declarative prototype (as above) in scope. This will give you - argument type checking, when available, and be harmless otherwise. */ -#ifdef __STDC__ -# define SCM_P(x) x -#else -# define SCM_P(x) () -#endif - - - -/* Define - * - * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1 - * SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) - * SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2) - */ - -#ifdef HAVE_LIMITS_H -# include <limits.h> -# ifdef UCHAR_MAX -# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L) -# else -# define SCM_CHAR_CODE_LIMIT 256L -# endif /* def UCHAR_MAX */ -# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) -# ifdef _UNICOS /* Stupid cray bug */ -# define SCM_MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4) -# else -# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2) -# endif /* UNICOS */ -#else -# define SCM_CHAR_CODE_LIMIT 256L -# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3)) -# if (0 != ~0) -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) -# else -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM) -# endif /* (0 != ~0) */ -#endif /* def HAVE_LIMITS_H */ - - -#ifdef STDC_HEADERS -# include <stdlib.h> -# ifdef AMIGA -# include <stddef.h> -# endif /* def AMIGA */ -# define scm_sizet size_t -#else -# ifdef _SIZE_T -# define scm_sizet size_t -# else -# define scm_sizet unsigned int -# endif /* def _SIZE_T */ -#endif /* def STDC_HEADERS */ - - - -#include "libguile/tags.h" - - -#ifdef vms -# ifndef CHEAP_CONTINUATIONS - typedef int jmp_buf[17]; - extern int setjump(jmp_buf env); - extern int longjump(jmp_buf env, int ret); -# define setjmp setjump -# define longjmp longjump -# else -# include <setjmp.h> -# endif -#else /* ndef vms */ -# ifdef _CRAY1 - typedef int jmp_buf[112]; - extern int setjump(jmp_buf env); - extern int longjump(jmp_buf env, int ret); -# define setjmp setjump -# define longjmp longjump -# else /* ndef _CRAY1 */ -# include <setjmp.h> -# endif /* ndef _CRAY1 */ -#endif /* ndef vms */ - -/* James Clark came up with this neat one instruction fix for - * continuations on the SPARC. It flushes the register windows so - * that all the state of the process is contained in the stack. - */ - -#ifdef sparc -# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3") -#else -# define SCM_FLUSH_REGISTER_WINDOWS /* empty */ -#endif - -/* If stack is not longword aligned then - */ - -/* #define SHORT_ALIGN */ -#ifdef THINK_C -# define SHORT_ALIGN -#endif -#ifdef MSDOS -# define SHORT_ALIGN -#endif -#ifdef atarist -# define SHORT_ALIGN -#endif - -#ifdef SHORT_ALIGN -typedef short SCM_STACKITEM; -#else -typedef long SCM_STACKITEM; -#endif - - -#ifndef USE_THREADS -#define SCM_THREAD_DEFER -#define SCM_THREAD_ALLOW -#define SCM_THREAD_REDEFER -#define SCM_THREAD_REALLOW_1 -#define SCM_THREAD_REALLOW_2 -#define SCM_THREAD_SWITCHING_CODE -#endif - -extern unsigned int scm_async_clock; -#if 0 -#define SCM_ASYNC_TICK \ -{ \ - if (0 == --scm_async_clock) \ - scm_async_click (); \ -} \ - -#else -#define SCM_ASYNC_TICK \ -{ \ - if (0 == --scm_async_clock) \ - scm_async_click (); \ - SCM_THREAD_SWITCHING_CODE; \ -} \ - -#endif - -#ifdef SCM_CAREFUL_INTS -#define SCM_CHECK_NOT_DISABLED \ - if (scm_ints_disabled) \ - fputs("ints already disabled\n", stderr); \ - -#define SCM_CHECK_NOT_ENABLED \ - if (!scm_ints_disabled) \ - fputs("ints already enabled\n", stderr); \ - -#else -#define SCM_CHECK_NOT_DISABLED -#define SCM_CHECK_NOT_ENABLED -#endif - - -#define SCM_DEFER_INTS \ -{ \ - SCM_CHECK_NOT_DISABLED; \ - SCM_THREAD_DEFER; \ - scm_ints_disabled = 1; \ -} \ - - -#define SCM_ALLOW_INTS_ONLY \ -{ \ - SCM_THREAD_ALLOW; \ - scm_ints_disabled = 0; \ -} \ - - -#define SCM_ALLOW_INTS \ -{ \ - SCM_CHECK_NOT_ENABLED; \ - SCM_THREAD_ALLOW; \ - scm_ints_disabled = 0; \ - SCM_ASYNC_TICK; \ -} \ - - -#define SCM_REDEFER_INTS \ -{ \ - SCM_THREAD_REDEFER; \ - ++scm_ints_disabled; \ -} \ - - -#define SCM_REALLOW_INTS \ -{ \ - SCM_THREAD_REALLOW_1; \ - --scm_ints_disabled; \ - if (!scm_ints_disabled) \ - { \ - SCM_THREAD_REALLOW_2; \ - SCM_ASYNC_TICK; \ - } \ -} \ - - - - - -/** SCM_ASSERT - ** - **/ - - -#ifdef SCM_RECKLESS -#define SCM_ASSERT(_cond, _arg, _pos, _subr) -#define SCM_ASRTGO(_cond, _label) -#else -#define SCM_ASSERT(_cond, _arg, _pos, _subr) \ - if (!(_cond)) \ - scm_wta(_arg, (char *)(_pos), _subr) -#define SCM_ASRTGO(_cond, _label) \ - if (!(_cond)) \ - goto _label -#endif - -#define SCM_ARGn 0 -#define SCM_ARG1 1 -#define SCM_ARG2 2 -#define SCM_ARG3 3 -#define SCM_ARG4 4 -#define SCM_ARG5 5 - /* #define SCM_ARG6 6 - #define SCM_ARG7 7 */ - /* #define SCM_ARGERR(X) ((X) < SCM_WNA \ - ? (char *)(X) \ - : "wrong type argument") - */ - -/* Following must match entry indexes in scm_errmsgs[]. - * Also, SCM_WNA must follow the last SCM_ARGn in sequence. - */ -#define SCM_WNA 8 - /* #define SCM_OVSCM_FLOW 9 */ -#define SCM_OUTOFRANGE 10 -#define SCM_NALLOC 11 - /* #define SCM_STACK_OVFLOW 12 */ - /* #define SCM_EXIT 13 */ - - -/* (...still matching scm_errmsgs) These - * are signals. Signals may become errors - * but are distinguished because they first - * try to invoke a handler that can resume - * the interrupted routine. - */ -#define SCM_HUP_SIGNAL 14 -#define SCM_INT_SIGNAL 15 -#define SCM_FPE_SIGNAL 16 -#define SCM_BUS_SIGNAL 17 -#define SCM_SEGV_SIGNAL 18 -#define SCM_ALRM_SIGNAL 19 -#define SCM_GC_SIGNAL 20 -#define SCM_TICK_SIGNAL 21 - -#define SCM_SIG_ORD(X) ((X) - SCM_HUP_SIGNAL) -#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL) -#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1) - -#if 0 -struct errdesc -{ - char *msg; - char *s_response; - short parent_err; -}; - - -extern struct errdesc scm_errmsgs[]; -#endif - - - -/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors - * were encountered. SCM_EXIT_FAILURE is the default code to return from - * SCM if errors were encountered. The return code can be explicitly - * specified in a SCM program with (scm_quit <n>). - */ - -#ifndef SCM_EXIT_SUCCESS -#ifdef vms -#define SCM_EXIT_SUCCESS 1 -#else -#define SCM_EXIT_SUCCESS 0 -#endif /* def vms */ -#endif /* ndef SCM_EXIT_SUCCESS */ -#ifndef SCM_EXIT_FAILURE -#ifdef vms -#define SCM_EXIT_FAILURE 2 -#else -#define SCM_EXIT_FAILURE 1 -#endif /* def vms */ -#endif /* ndef SCM_EXIT_FAILURE */ - - - - - -#endif /* __SCMH */ diff --git a/libguile/_scm.h b/libguile/_scm.h deleted file mode 100644 index 88d771a0a..000000000 --- a/libguile/_scm.h +++ /dev/null @@ -1,124 +0,0 @@ -/* classes: h_files */ - -#ifndef _SCMH -#define _SCMH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "__scm.h" - -/* This file is only visible to the libguile sources */ - -/* Include headers for those files central to the implementation. The - rest should be explicitly #included in the C files themselves. */ -#include "error.h" /* Everyone signals errors. */ -#include "print.h" /* Everyone needs to print. */ -#include "pairs.h" /* Everyone conses. */ -#include "list.h" /* Everyone makes lists. */ -#include "gc.h" /* Everyone allocates. */ -#include "gsubr.h" /* Everyone defines global functions. */ -#include "procs.h" /* Same. */ -#include "numbers.h" /* Everyone deals with fixnums. */ -#include "symbols.h" /* For length, chars, values, miscellany. */ -#include "boolean.h" /* Everyone wonders about the truth. */ -#include "strings.h" /* Everyone loves string. */ -#include "vectors.h" /* Vectors are used for structures a lot. */ -#include "root.h" /* Everyone uses these objects. */ -#include "ports.h" /* Everyone does I/O. */ -#include "async.h" /* Everyone allows/disallows ints. */ -#ifdef USE_THREADS -#include "../threads/threads.h" /* Some thread packages does switching - at async ticks. */ -#endif -#include "snarf.h" /* Everyone snarfs. */ - -/* On VMS, GNU C's errno.h contains a special hack to get link attributes - * for errno correct for linking to the C RTL. - */ -#include <errno.h> - -/* SCM_SYSCALL retries system calls that have been interrupted (EINTR) */ -#ifdef vms -# ifndef __GNUC__ -# include <ssdef.h> -# define SCM_SYSCALL(line) do{errno = 0;line;} \ - while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) -# endif /* ndef __GNUC__ */ -#endif /* def vms */ - -#ifndef SCM_SYSCALL -# ifdef EINTR -# if (EINTR > 0) -# define SCM_SYSCALL(line) do{errno = 0;line;}while(EINTR==errno) -# endif /* (EINTR > 0) */ -# endif /* def EINTR */ -#endif /* ndef SCM_SYSCALL */ - -#ifndef SCM_SYSCALL -# define SCM_SYSCALL(line) {line;} -#endif /* ndef SCM_SYSCALL */ - -#ifndef MSDOS -# ifdef ARM_ULIB - extern volatile int errno; -# else - extern int errno; -# endif /* def ARM_ULIB */ -#endif /* ndef MSDOS */ -#ifdef __TURBOC__ -# if (__TURBOC__==1) - /* Needed for TURBOC V1.0 */ - extern int errno; -# endif /* (__TURBOC__==1) */ -#endif /* def __TURBOC__ */ - - - -#ifndef min -#define min(A,B) ((A) <= (B) ? (A) : (B)) -#endif -#ifndef max -#define max(A,B) ((A) >= (B) ? (A) : (B)) -#endif - -#endif /* _SCMH */ - diff --git a/libguile/acconfig.h b/libguile/acconfig.h deleted file mode 100644 index ded2b044b..000000000 --- a/libguile/acconfig.h +++ /dev/null @@ -1,81 +0,0 @@ -/* acconfig.h --- documentation for symbols possibly defined in scmconfig.h - Jim Blandy <jimb@cyclic.com> --- August 1996 */ - -/* Define these two if you want support for debugging of Scheme - programs. */ -#undef DEBUG_EXTENSIONS -#undef READER_EXTENSIONS - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Set this to the name of a field in FILE which contains the number - of buffered characters waiting to be read. */ -#undef FILE_CNT_FIELD - -/* Define this if your stdio has _gptr and _egptr fields which can - be compared to give the number of buffered characters waiting to - be read. */ -#undef FILE_CNT_GPTR - -/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields - which can be compared to give the number of buffered characters - waiting to be read. */ -#undef FILE_CNT_READPTR - -/* Define this if your system defines struct linger, for use with the - getsockopt and setsockopt system calls. */ -#undef HAVE_STRUCT_LINGER - -/* Define this if floats are the same size as longs. */ -#undef SCM_SINGLES - -/* Define this if a callee's stack frame has a higher address than the - caller's stack frame. On most machines, this is not the case. */ -#undef SCM_STACK_GROWS_UP - -/* Define this if <utime.h> doesn't define struct utimbuf unless - _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */ -#undef UTIMBUF_NEEDS_POSIX - -/* Define this if we should #include <libc.h> when we've already - #included <unistd.h>. On some systems, they conflict, and libc.h - should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in - aclocal.m4. */ -#undef LIBC_H_WITH_UNISTD_H - -/* Define these to indicate the current version of Guile. These - values are supposed to be supplied by the configuration system. */ -#undef GUILE_MAJOR_VERSION -#undef GUILE_MINOR_VERSION -#undef GUILE_VERSION - -/* Define if using cooperative multithreading. */ -#undef USE_COOP_THREADS - -/* Define if using "FSU" pthreads. */ -#undef USE_FSU_PTHREADS - -/* Define if using MIT pthreads. */ -#undef USE_MIT_PTHREADS - -/* Define if using PCthreads pthreads. */ -#undef USE_PCTHREADS_PTHREADS - -/* Define if using any sort of threads. */ -#undef USE_THREADS - -/* Name of this package. */ -#undef PACKAGE - -/* Define if you want support for dynamic linking. */ -#undef DYNAMIC_LINKING diff --git a/libguile/acinclude.m4 b/libguile/acinclude.m4 deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/acinclude.m4 +++ /dev/null diff --git a/libguile/aclocal.m4 b/libguile/aclocal.m4 deleted file mode 100644 index 0ddeceb4f..000000000 --- a/libguile/aclocal.m4 +++ /dev/null @@ -1,240 +0,0 @@ -dnl aclocal.m4 generated automatically by aclocal 1.1l - -dnl On the NeXT, #including <utime.h> doesn't give you a definition for -dnl struct utime, unless you #define _POSIX_SOURCE. - -AC_DEFUN(GUILE_STRUCT_UTIMBUF, [ - AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf], - guile_cv_struct_utimbuf_needs_posix, - [AC_TRY_CPP([ -#ifdef __EMX__ -#include <sys/utime.h> -#else -#include <utime.h> -#endif -struct utime blah; -], - guile_cv_struct_utimbuf_needs_posix=no, - guile_cv_struct_utimbuf_needs_posix=yes)]) - if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then - AC_DEFINE(UTIMBUF_NEEDS_POSIX) - fi]) - - - - -dnl -dnl Apparently, at CMU they have a weird version of libc.h that is -dnl installed in /usr/local/include and conflicts with unistd.h. -dnl In these situations, we should not #include libc.h. -dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is -dnl present on the system, and is safe to #include. -dnl -AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD], - [ - AC_CHECK_HEADERS(libc.h unistd.h) - AC_CACHE_CHECK( - "whether libc.h and unistd.h can be included together", - guile_cv_header_libc_with_unistd, - [ - if test "$ac_cv_header_libc_h" = "no"; then - guile_cv_header_libc_with_unistd="no" - elif test "$ac_cv_header_unistd.h" = "no"; then - guile_cv_header_libc_with_unistd="yes" - else - AC_TRY_COMPILE( - [ -# include <libc.h> -# include <unistd.h> - ], - [], - [guile_cv_header_libc_with_unistd=yes], - [guile_cv_header_libc_with_unistd=no] - ) - fi - ] - ) - if test "$guile_cv_header_libc_with_unistd" = yes; then - AC_DEFINE(LIBC_H_WITH_UNISTD_H) - fi - ] -) - -# Like AC_CONFIG_HEADER, but automatically create stamp file. - -AC_DEFUN(AM_CONFIG_HEADER, -[AC_PREREQ([2.12]) -AC_CONFIG_HEADER([$1]) -dnl When config.status generates a header, we must update the stamp-h file. -dnl This file resides in the same directory as the config header -dnl that is generated. We must strip everything past the first ":", -dnl and everything past the last "/". -AC_OUTPUT_COMMANDS(changequote(<<,>>)dnl -test -z "<<$>>CONFIG_HEADER" || echo timestamp > patsubst(<<$1>>, <<^\([^:]*/\)?.*>>, <<\1>>)stamp-h<<>>dnl -changequote([,]))]) - - -dnl Usage: AM_INIT_GUILE_MODULE(module-name) -dnl This macro will automatically get the guile version from the -dnl top-level srcdir, and will initialize automake. It also -dnl defines the `module' variable. -AC_DEFUN([AM_INIT_GUILE_MODULE],[ -. $srcdir/../GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) -AC_CONFIG_AUX_DIR(..) -module=[$1] -AC_SUBST(module)]) - -# Do all the work for Automake. This macro actually does too much -- -# some checks are only needed if your package does certain things. -# But this isn't really a big deal. - -# serial 1 - -dnl Usage: -dnl AM_INIT_AUTOMAKE(package,version) - -AC_DEFUN(AM_INIT_AUTOMAKE, -[AC_REQUIRE([AM_PROG_INSTALL]) -PACKAGE=[$1] -AC_SUBST(PACKAGE) -AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") -VERSION=[$2] -AC_SUBST(VERSION) -AC_DEFINE_UNQUOTED(VERSION, "$VERSION") -AM_SANITY_CHECK -AC_ARG_PROGRAM -AC_PROG_MAKE_SET]) - - -# serial 1 - -AC_DEFUN(AM_PROG_INSTALL, -[AC_REQUIRE([AC_PROG_INSTALL]) -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' -AC_SUBST(INSTALL_SCRIPT)dnl -]) - -# -# Check to make sure that the build environment is sane. -# - -AC_DEFUN(AM_SANITY_CHECK, -[AC_MSG_CHECKING([whether build environment is sane]) -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -rm -f conftest* -AC_MSG_RESULT(yes)]) - -dnl -dnl CY_AC_WITH_THREADS determines which thread library the user intends -dnl to put underneath guile. Pass it the path to find the guile top-level -dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix. -dnl - -AC_DEFUN([CY_AC_WITH_THREADS],[ -AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[ -AC_CACHE_VAL(cy_cv_threads_cflags,[ -AC_CACHE_VAL(cy_cv_threads_libs,[ -use_threads=no; -AC_ARG_WITH(threads,[ --with-threads thread interface], - use_threads=$withval, use_threads=no) -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then -dnl -dnl Test for the qt threads package - used for cooperative threads -dnl This may not necessarily be built yet - so just check for the -dnl header files. -dnl - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then -dnl -dnl Test for the FSU threads package -dnl - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=FSU) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the MIT threads package -dnl - LIBS="-lpthread" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=MIT) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the PCthreads package -dnl - LIBS="-lpthreads" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=PCthreads) - fi -dnl -dnl Set the appropriate flags! -dnl - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - AC_MSG_ERROR("cannot find thread library installation") - fi -fi -]) -]) -], -dnl -dnl Set flags according to what is cached. -dnl -CPPFLAGS="$cy_cv_threads_cflags" -LIBS="$cy_cv_threads_libs" -) -]) - diff --git a/libguile/alist.c b/libguile/alist.c deleted file mode 100644 index 06ede611a..000000000 --- a/libguile/alist.c +++ /dev/null @@ -1,380 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" -#include "list.h" - -#include "alist.h" - - - -SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons); - -SCM -scm_acons (w, x, y) - SCM w; - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, w); - SCM_SETCDR (z, x); - x = z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - return z; -} - - - -SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq); - -SCM -scm_sloppy_assq(x, alist) - SCM x; - SCM alist; -{ - - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x)) - return tmp; - } - return SCM_BOOL_F; -} - - - -SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv); - -SCM -scm_sloppy_assv(x, alist) - SCM x; - SCM alist; -{ - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) - && SCM_CONSP (tmp) - && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x))) - return tmp; - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc); - -SCM -scm_sloppy_assoc(x, alist) - SCM x; - SCM alist; -{ - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) - && SCM_CONSP (tmp) - && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x))) - return tmp; - } - return SCM_BOOL_F; -} - - - - -SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq); - -SCM -scm_assq(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq); - if (SCM_CAR(tmp)==x) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq); - return SCM_BOOL_F; -} - - -SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv); - -SCM -scm_assv(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASRTGO(SCM_CONSP(alist), badlst); - tmp = SCM_CAR(alist); - SCM_ASRTGO(SCM_NIMP(tmp) && SCM_CONSP(tmp), badlst); - if SCM_NFALSEP(scm_eqv_p(SCM_CAR(tmp), x)) return tmp; - } -# ifndef RECKLESS - if (!(SCM_NULLP(alist))) - badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv); -# endif - return SCM_BOOL_F; -} - - -SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc); - -SCM -scm_assoc(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc); - if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc); - return SCM_BOOL_F; -} - - - - -SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref); - -SCM -scm_assq_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref); - -SCM -scm_assv_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref); - -SCM -scm_assoc_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - - - - - -SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x); - -SCM -scm_assq_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - -SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x); - -SCM -scm_assv_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - -SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x); - -SCM -scm_assoc_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - - - - -SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x); - -SCM -scm_assq_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delq_x (handle, alist); - } - else - return alist; -} - - -SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x); - -SCM -scm_assv_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delv_x (handle, alist); - } - else - return alist; -} - - -SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x); - -SCM -scm_assoc_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delete_x (handle, alist); - } - else - return alist; -} - - - - - - -void -scm_init_alist () -{ -#include "alist.x" -} - diff --git a/libguile/alist.h b/libguile/alist.h deleted file mode 100644 index 87e327fdd..000000000 --- a/libguile/alist.h +++ /dev/null @@ -1,69 +0,0 @@ -/* classes: h_files */ - -#ifndef ALISTH -#define ALISTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_acons SCM_P ((SCM w, SCM x, SCM y)); -extern SCM scm_sloppy_assq SCM_P ((SCM x, SCM alist)); -extern SCM scm_sloppy_assv SCM_P ((SCM x, SCM alist)); -extern SCM scm_sloppy_assoc SCM_P ((SCM x, SCM alist)); -extern SCM scm_assq SCM_P ((SCM x, SCM alist)); -extern SCM scm_assv SCM_P ((SCM x, SCM alist)); -extern SCM scm_assoc SCM_P ((SCM x, SCM alist)); -extern SCM scm_assq_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assv_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assoc_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assq_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assv_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assoc_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assq_remove_x SCM_P ((SCM alist, SCM key)); -extern SCM scm_assv_remove_x SCM_P ((SCM alist, SCM key)); -extern SCM scm_assoc_remove_x SCM_P ((SCM alist, SCM key)); -extern void scm_init_alist SCM_P ((void)); - -#endif /* ALISTH */ diff --git a/libguile/append.c b/libguile/append.c deleted file mode 100644 index 204d57ab8..000000000 --- a/libguile/append.c +++ /dev/null @@ -1,78 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "list.h" - -#include "append.h" - - - -SCM_PROC (s_append, "append", 0, 0, 1, scm_append); - -SCM -scm_append (objs) - SCM objs; -{ - return scm_list_append (objs); -} - - -SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x); - -SCM -scm_append_x (objs) - SCM objs; -{ - return scm_list_append_x (objs); -} - - - - -void -scm_init_append () -{ -#include "append.x" -} - diff --git a/libguile/append.h b/libguile/append.h deleted file mode 100644 index 9c13d6356..000000000 --- a/libguile/append.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef APPENDH -#define APPENDH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_append SCM_P ((SCM objs)); -extern SCM scm_append_x SCM_P ((SCM objs)); -extern void scm_init_append SCM_P ((void)); - -#endif /* APPENDH */ diff --git a/libguile/appinit.c b/libguile/appinit.c deleted file mode 100644 index 1dff367f3..000000000 --- a/libguile/appinit.c +++ /dev/null @@ -1,52 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - - - - -void -scm_appinit () -{ -} diff --git a/libguile/arbiters.c b/libguile/arbiters.c deleted file mode 100644 index 292f4fec1..000000000 --- a/libguile/arbiters.c +++ /dev/null @@ -1,133 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "smob.h" - -#include "arbiters.h" - - -/* {Arbiters} - * - * These procedures implement synchronization primitives. Processors - * with an atomic test-and-set instruction can use it here (and not - * SCM_DEFER_INTS). - */ - -static long scm_tc16_arbiter; - - -static int -prinarb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<arbiter ", port); - if (SCM_CAR (exp) & (1L << 16)) - scm_gen_puts (scm_regular_string, "locked ", port); - scm_iprin1 (SCM_CDR (exp), port, pstate); - scm_gen_putc ('>', port); - return !0; -} - -static scm_smobfuns arbsmob = -{ - scm_markcdr, scm_free0, prinarb, 0 -}; - -SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter); - -SCM -scm_make_arbiter (name) - SCM name; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, name); - SCM_SETCAR (z, scm_tc16_arbiter); - return z; -} - -SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter); - -SCM -scm_try_arbiter (arb) - SCM arb; -{ - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter); - SCM_DEFER_INTS; - if (SCM_CAR (arb) & (1L << 16)) - arb = SCM_BOOL_F; - else - { - SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16)); - arb = SCM_BOOL_T; - } - SCM_ALLOW_INTS; - return arb; -} - - -SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter); - -SCM -scm_release_arbiter (arb) - SCM arb; -{ - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter); - if (!(SCM_CAR (arb) & (1L << 16))) - return SCM_BOOL_F; - SCM_SETCAR (arb, scm_tc16_arbiter); - return SCM_BOOL_T; -} - - - -void -scm_init_arbiters () -{ - scm_tc16_arbiter = scm_newsmob (&arbsmob); -#include "arbiters.x" -} - diff --git a/libguile/arbiters.h b/libguile/arbiters.h deleted file mode 100644 index 5e34ce297..000000000 --- a/libguile/arbiters.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef ARBITERSH -#define ARBITERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_make_arbiter SCM_P ((SCM name)); -extern SCM scm_try_arbiter SCM_P ((SCM arb)); -extern SCM scm_release_arbiter SCM_P ((SCM arb)); -extern void scm_init_arbiters SCM_P ((void)); - -#endif /* ARBITERSH */ diff --git a/libguile/async.c b/libguile/async.c deleted file mode 100644 index d2478fd65..000000000 --- a/libguile/async.c +++ /dev/null @@ -1,674 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <signal.h> -#include "_scm.h" -#include "eval.h" -#include "throw.h" -#include "smob.h" - -#include "async.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - -/* {Asynchronous Events} - * - * - * Async == thunk + mark. - * - * Setting the mark guarantees future execution of the thunk. More - * than one set may be satisfied by a single execution. - * - * scm_tick_clock decremented once per SCM_ALLOW_INTS. - * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0. - * Async execution prevented by scm_mask_ints != 0. - * - * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock - * to 1. - * - * If the clock reaches 0 any other time, run marked asyncs. - * - * From a unix signal handler, mark a corresponding async and set the clock - * to 1. Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not - * called in the dynamic scope of a critical section, it is excecuted immediately. - * - * Overall, closely timed signals of a particular sort may be combined. Pending signals - * are delivered in a fixed priority order, regardless of arrival order. - * - */ - - - -unsigned int scm_async_clock = 20; -static unsigned int scm_async_rate = 20; -unsigned int scm_mask_ints = 1; - -static unsigned int scm_tick_clock = 0; -static unsigned int scm_tick_rate = 0; -static unsigned int scm_desired_tick_rate = 0; -static unsigned int scm_switch_clock = 0; -static unsigned int scm_switch_rate = 0; -static unsigned int scm_desired_switch_rate = 0; - -static SCM system_signal_asyncs[SCM_NUM_SIGS]; -static SCM handler_var; -static SCM symbol_signal; - - -struct scm_async -{ - int got_it; /* needs to be delivered? */ - SCM thunk; /* the handler. */ -}; - - -static long scm_tc16_async; - -#define SCM_ASYNCP(X) (scm_tc16_async == SCM_GCTYP16 (X)) -#define SCM_ASYNC(X) ((struct scm_async *)SCM_CDR (X)) - - - - - - -static int asyncs_pending SCM_P ((void)); - -static int -asyncs_pending () -{ - SCM pos; - pos = scm_asyncs; - while (pos != SCM_EOL) - { - SCM a; - struct scm_async * it; - a = SCM_CAR (pos); - it = SCM_ASYNC (a); - if (it->got_it) - return 1; - pos = SCM_CDR (pos); - } - return 0; -} - - - -void -scm_async_click () -{ - int owe_switch; - int owe_tick; - - if (!scm_switch_rate) - { - owe_switch = 0; - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - { - owe_switch = (scm_async_rate >= scm_switch_clock); - if (owe_switch) - { - if (scm_desired_switch_rate) - { - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - scm_switch_clock = scm_switch_rate; - } - else - { - if (scm_desired_switch_rate) - { - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - scm_switch_clock -= scm_async_rate; - } - } - - if (scm_mask_ints) - { - if (owe_switch) - scm_switch (); - scm_async_clock = 1; - return;; - } - - if (!scm_tick_rate) - { - unsigned int r; - owe_tick = 0; - r = scm_desired_tick_rate; - if (r) - { - scm_desired_tick_rate = 0; - scm_tick_rate = r; - scm_tick_clock = r; - } - } - else - { - owe_tick = (scm_async_rate >= scm_tick_clock); - if (owe_tick) - { - scm_tick_clock = scm_tick_rate = scm_desired_tick_rate; - scm_desired_tick_rate = 0; - } - else - { - if (scm_desired_tick_rate) - { - scm_tick_clock = scm_tick_rate = scm_desired_tick_rate; - scm_desired_tick_rate = 0; - } - else - scm_tick_clock -= scm_async_rate; - } - } - - if (owe_tick) - scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); - - SCM_DEFER_INTS; - if (scm_tick_rate && scm_switch_rate) - { - scm_async_rate = min (scm_tick_clock, scm_switch_clock); - scm_async_clock = scm_async_rate; - } - else if (scm_tick_rate) - { - scm_async_clock = scm_async_rate = scm_tick_clock; - } - else if (scm_switch_rate) - { - scm_async_clock = scm_async_rate = scm_switch_clock; - } - else - scm_async_clock = scm_async_rate = 1 << 16; - SCM_ALLOW_INTS_ONLY; - - tail: - scm_run_asyncs (scm_asyncs); - - SCM_DEFER_INTS; - if (asyncs_pending ()) - { - SCM_ALLOW_INTS_ONLY; - goto tail; - } - SCM_ALLOW_INTS; - - if (owe_switch) - scm_switch (); -} - - - - - -void -scm_switch () -{ -#if 0 /* Thread switching code should probably reside here, but the - async switching code doesn't seem to work, so it's put in the - SCM_ASYNC_TICK macro instead. /mdj */ - SCM_THREAD_SWITCHING_CODE; -#endif -} - - - -static void scm_deliver_signal SCM_P ((int num)); - -static void -scm_deliver_signal (num) - int num; -{ - SCM handler; - handler = SCM_CDR (handler_var); - if (handler != SCM_BOOL_F) - scm_apply (handler, SCM_MAKINUM (num), scm_listofnull); - else - { - scm_mask_ints = 0; - scm_throw (symbol_signal, - scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED)); - } -} - - - - - -static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -print_async (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<async ", port); - scm_intprint(exp, 16, port); - scm_gen_putc('>', port); - return 1; -} - - -static SCM mark_async SCM_P ((SCM obj)); - -static SCM -mark_async (obj) - SCM obj; -{ - struct scm_async * it; - if (SCM_GC8MARKP (obj)) - return SCM_BOOL_F; - SCM_SETGC8MARK (obj); - it = SCM_ASYNC (obj); - return it->thunk; -} - - -static scm_sizet free_async SCM_P ((SCM obj)); - -static scm_sizet -free_async (obj) - SCM obj; -{ - struct scm_async * it; - it = SCM_ASYNC (obj); - scm_must_free ((char *)it); - return (sizeof (*it)); -} - - -static scm_smobfuns async_smob = -{ - mark_async, - free_async, - print_async, - 0 -}; - - - - -SCM_PROC(s_async, "async", 1, 0, 0, scm_async); - -SCM -scm_async (thunk) - SCM thunk; -{ - SCM it; - struct scm_async * async; - - SCM_NEWCELL (it); - SCM_DEFER_INTS; - SCM_SETCDR (it, SCM_EOL); - async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async); - async->got_it = 0; - async->thunk = thunk; - SCM_SETCDR (it, (SCM)async); - SCM_SETCAR (it, (SCM)scm_tc16_async); - SCM_ALLOW_INTS; - return it; -} - -SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async); - -SCM -scm_system_async (thunk) - SCM thunk; -{ - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_DEFER_INTS; - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; - SCM_ALLOW_INTS; - return it; -} - -SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark); - -SCM -scm_async_mark (a) - SCM a; -{ - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - it->got_it = 1; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark); - -SCM -scm_system_async_mark (a) - SCM a; -{ - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - SCM_REDEFER_INTS; - it->got_it = 1; - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs); - -SCM -scm_run_asyncs (list_of_a) - SCM list_of_a; -{ - SCM pos; - - if (scm_mask_ints) - return SCM_BOOL_F; - pos = list_of_a; - while (pos != SCM_EOL) - { - SCM a; - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs); - a = SCM_CAR (pos); - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs); - it = SCM_ASYNC (a); - scm_mask_ints = 1; - if (it->got_it) - { - it->got_it = 0; - scm_apply (it->thunk, SCM_EOL, SCM_EOL); - } - scm_mask_ints = 0; - pos = SCM_CDR (pos); - } - return SCM_BOOL_T; -} - - - - -SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop); - -SCM -scm_noop (args) - SCM args; -{ - return (SCM_NULLP (args) - ? SCM_BOOL_F - : SCM_CAR (args)); -} - - - - -SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate); - -SCM -scm_set_tick_rate (n) - SCM n; -{ - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate); - old_n = scm_tick_rate; - scm_desired_tick_rate = SCM_INUM (n); - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - return SCM_MAKINUM (old_n); -} - - - - -SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate); - -SCM -scm_set_switch_rate (n) - SCM n; -{ - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate); - old_n = scm_switch_rate; - scm_desired_switch_rate = SCM_INUM (n); - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - return SCM_MAKINUM (old_n); -} - - - - -static SCM scm_sys_hup_async_thunk SCM_P ((void)); - -static SCM -scm_sys_hup_async_thunk () -{ - scm_deliver_signal (SCM_HUP_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_int_async_thunk SCM_P ((void)); - -static SCM -scm_sys_int_async_thunk () -{ - scm_deliver_signal (SCM_INT_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_fpe_async_thunk SCM_P ((void)); - -static SCM -scm_sys_fpe_async_thunk () -{ - scm_deliver_signal (SCM_FPE_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_bus_async_thunk SCM_P ((void)); - -static SCM -scm_sys_bus_async_thunk () -{ - scm_deliver_signal (SCM_BUS_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_segv_async_thunk SCM_P ((void)); - -static SCM -scm_sys_segv_async_thunk () -{ - scm_deliver_signal (SCM_SEGV_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_alrm_async_thunk SCM_P ((void)); - -static SCM -scm_sys_alrm_async_thunk () -{ - scm_deliver_signal (SCM_ALRM_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_gc_async_thunk SCM_P ((void)); - -static SCM -scm_sys_gc_async_thunk () -{ - scm_deliver_signal (SCM_GC_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_tick_async_thunk SCM_P ((void)); - -static SCM -scm_sys_tick_async_thunk () -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} - - - - - - -SCM -scm_take_signal (n) - int n; -{ - SCM ignored; - if (!scm_ints_disabled) - { - /* For reasons of speed, the SCM_NEWCELL macro doesn't defer - interrupts. Instead, it first sets its argument to point to - the first cell in the list, and then advances the freelist - pointer to the next cell. Now, if this procedure is - interrupted, the only anomalous state possible is to have - both SCM_NEWCELL's argument and scm_freelist pointing to the - same cell. To deal with this case, we always throw away the - first cell in scm_freelist here. - - At least, that's the theory. I'm not convinced that that's - the only anomalous path we need to worry about. */ - SCM_NEWCELL (ignored); - } - scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]); - return SCM_BOOL_F; -} - - - -SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals); - -SCM -scm_unmask_signals () -{ - scm_mask_ints = 0; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); - -SCM -scm_mask_signals () -{ - scm_mask_ints = 1; - return SCM_UNSPECIFIED; -} - - - - -void -scm_init_async () -{ - SCM a_thunk; - scm_tc16_async = scm_newsmob (&async_smob); - symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED)); - scm_permanent_object (symbol_signal); - - /* These are in the opposite order of delivery priortity. - * - * Error conditions are given low priority: - */ - a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk); - - - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk); - - /* Clock and PC driven conditions are given highest priority. */ - a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk); - - handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED); - SCM_SETCDR (handler_var, SCM_BOOL_F); - scm_permanent_object (handler_var); -#include "async.x" -} diff --git a/libguile/async.h b/libguile/async.h deleted file mode 100644 index 217603ba6..000000000 --- a/libguile/async.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef ASYNCH -#define ASYNCH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -extern unsigned int scm_mask_ints; - - - -extern void scm_async_click SCM_P ((void)); -extern void scm_switch SCM_P ((void)); -extern SCM scm_async SCM_P ((SCM thunk)); -extern SCM scm_system_async SCM_P ((SCM thunk)); -extern SCM scm_async_mark SCM_P ((SCM a)); -extern SCM scm_system_async_mark SCM_P ((SCM a)); -extern SCM scm_run_asyncs SCM_P ((SCM list_of_a)); -extern SCM scm_noop SCM_P ((SCM args)); -extern SCM scm_set_tick_rate SCM_P ((SCM n)); -extern SCM scm_set_switch_rate SCM_P ((SCM n)); -extern SCM scm_take_signal SCM_P ((int n)); -extern SCM scm_unmask_signals SCM_P ((void)); -extern SCM scm_mask_signals SCM_P ((void)); -extern void scm_init_async SCM_P ((void)); - -#endif /* ASYNCH */ diff --git a/libguile/backtrace.c b/libguile/backtrace.c deleted file mode 100644 index 365b6ca58..000000000 --- a/libguile/backtrace.c +++ /dev/null @@ -1,436 +0,0 @@ -/* Printing of backtraces and error messages - * Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - -#include <stdio.h> -#include "_scm.h" -#include "stacks.h" -#include "srcprop.h" -#include "genio.h" -#include "struct.h" -#include "strports.h" - -#include "backtrace.h" - -/* {Error reporting and backtraces} - * (A first approximation.) - * - * Note that these functions shouldn't generate errors themselves. - */ - -#ifndef SCM_RECKLESS -#undef SCM_ASSERT -#define SCM_ASSERT(_cond, _arg, _pos, _subr) \ - if (!(_cond)) \ - return SCM_BOOL_F; -#endif - -static void display_header SCM_P ((SCM source, SCM port)); -static void -display_header (source, port) - SCM source; - SCM port; -{ - SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source) - ? scm_source_property (source, scm_i_filename) - : SCM_BOOL_F); - if (SCM_NIMP (fname) && SCM_STRINGP (fname)) - { - scm_prin1 (fname, port, 0); - scm_gen_putc (':', port); - scm_prin1 (scm_source_property (source, scm_i_line), port, 0); - scm_gen_putc (':', port); - scm_prin1 (scm_source_property (source, scm_i_column), port, 0); - } - else - scm_gen_puts (scm_regular_string, "ERROR", port); - scm_gen_puts (scm_regular_string, ": ", port); -} - - -void -scm_display_error_message (message, args, port) - SCM message; - SCM args; - SCM port; -{ - int writingp; - char *start; - char *p; - - if (!SCM_STRINGP (message) || SCM_IMP (args) || !scm_list_p (args)) - { - scm_prin1 (message, port, 0); - scm_gen_putc ('\n', port); - return; - } - - start = SCM_CHARS (message); - for (p = start; *p != '\0'; ++p) - if (*p == '%') - { - if (SCM_IMP (args) || SCM_NCONSP (args)) - continue; - - ++p; - if (*p == 's') - writingp = 0; - else if (*p == 'S') - writingp = 1; - else - continue; - - scm_gen_write (scm_regular_string, start, p - start - 1, port); - scm_prin1 (SCM_CAR (args), port, writingp); - args = SCM_CDR (args); - start = p + 1; - } - scm_gen_write (scm_regular_string, start, p - start, port); - scm_gen_putc ('\n', port); -} - -static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port)); -static void -display_expression (frame, pname, source, port) - SCM frame; - SCM pname; - SCM source; - SCM port; -{ - SCM print_state = scm_make_print_state (); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 0; - pstate->fancyp = 1; - pstate->level = 2; - pstate->length = 3; - if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)) - { - if (SCM_NIMP (frame) - && SCM_FRAMEP (frame) - && SCM_FRAME_EVAL_ARGS_P (frame)) - scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port); - else - scm_gen_puts (scm_regular_string, "In procedure ", port); - scm_iprin1 (pname, port, pstate); - if (SCM_NIMP (source) && SCM_MEMOIZEDP (source)) - { - scm_gen_puts (scm_regular_string, " in expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_unmemoize (source), port, pstate); - } - } - else if (SCM_NIMP (source)) - { - scm_gen_puts (scm_regular_string, "In expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_unmemoize (source), port, pstate); - } - scm_gen_puts (scm_regular_string, ":\n", port); - scm_free_print_state (print_state); -} - -SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error); -SCM -scm_display_error (stack, port, subr, message, args, rest) - SCM stack; - SCM port; - SCM subr; - SCM message; - SCM args; - SCM rest; -{ - SCM current_frame = SCM_BOOL_F; - SCM source = SCM_BOOL_F; - SCM pname = SCM_BOOL_F; - if (SCM_DEBUGGINGP - && SCM_NIMP (stack) - && SCM_STACKP (stack) - && SCM_STACK_LENGTH (stack) > 0) - { - current_frame = scm_stack_ref (stack, SCM_INUM0); - source = SCM_FRAME_SOURCE (current_frame); - if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source))) - source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame)); - if (SCM_FRAME_PROC_P (current_frame) - && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T) - pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); - } - if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname))) - pname = subr; - if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source)) - || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))) - { - display_header (source, port); - display_expression (current_frame, pname, source, port); - } - display_header (source, port); - scm_display_error_message (message, args, port); - return SCM_UNSPECIFIED; -} - -static void indent SCM_P ((int n, SCM port)); -static void -indent (n, port) - int n; - SCM port; -{ - int i; - for (i = 0; i < n; ++i) - scm_gen_putc (' ', port); -} - -static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)); -static void -display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate) - char *hdr; - SCM exp; - char *tlr; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; -{ - pstate->level = 2; - pstate->length = 3; - if (SCM_NIMP (exp) && SCM_CONSP (exp)) - { - scm_iprlist (hdr, exp, tlr[0], port, pstate); - scm_gen_puts (scm_regular_string, &tlr[1], port); - } - else - scm_iprin1 (exp, port, pstate); - scm_gen_putc ('\n', port); -} - -static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)); -static void -display_frame (frame, nfield, indentation, sport, port, pstate) - SCM frame; - int nfield; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; -{ - int n, i, j; - - /* Announce missing frames? */ - if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_gen_puts (scm_regular_string, "...\n", port); - } - - /* Check size of frame number. */ - n = SCM_FRAME_NUMBER (frame); - for (i = 0, j = n; j > 0; ++i) j /= 10; - - /* Number indentation. */ - indent (nfield - (i ? i : 1), port); - - /* Frame number. */ - scm_iprin1 (SCM_MAKINUM (n), port, pstate); - - /* Real frame marker */ - scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port); - - /* Indentation. */ - indent (indentation, port); - - if (SCM_FRAME_PROC_P (frame)) - /* Display an application. */ - { - SCM proc = SCM_FRAME_PROC (frame); - SCM name = (SCM_NFALSEP (scm_procedure_p (proc)) - ? scm_procedure_name (proc) - : SCM_BOOL_F); - display_frame_expr ("[", - scm_cons (SCM_NFALSEP (name) ? name : proc, - SCM_FRAME_ARGS (frame)), - SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]", - nfield + 1 + indentation, - sport, - port, - pstate); - } - else - /* Display a special form. */ - { - SCM source = SCM_FRAME_SOURCE (frame); - SCM copy = scm_source_property (source, scm_i_copy); - display_frame_expr ("(", - SCM_NIMP (copy) && SCM_CONSP (copy) - ? copy - : scm_unmemoize (source), - ")", - nfield + 1 + indentation, - sport, - port, - pstate); - } - - /* Announce missing frames? */ - if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_gen_puts (scm_regular_string, "...\n", port); - } -} - -SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace); -SCM -scm_display_backtrace (stack, port, first, depth) - SCM stack; - SCM port; - SCM first; - SCM depth; -{ - int n_frames, beg, end, n, i, j; - int nfield, indent_p, indentation; - SCM frame, sport, print_state; - scm_print_state *pstate; - - /* Argument checking and extraction. */ - SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack), - stack, - SCM_ARG1, - s_display_backtrace); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), - port, - SCM_ARG2, - s_display_backtrace); - n_frames = SCM_INUM (scm_stack_length (stack)); - n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH; - if (SCM_BACKWARDS_P) - { - beg = SCM_INUMP (first) ? SCM_INUM (first) : 0; - end = beg + n - 1; - if (end >= n_frames) - end = n_frames - 1; - n = end - beg + 1; - } - else - { - if (SCM_INUMP (first)) - { - beg = SCM_INUM (first); - end = beg - n + 1; - if (end < 0) - end = 0; - } - else - { - beg = n - 1; - end = 0; - if (beg >= n_frames) - beg = n_frames - 1; - } - n = beg - end + 1; - } - SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace); - SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace); - - /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s_display_backtrace); - - /* Create a print state for printing of frames. */ - print_state = scm_make_print_state (); - pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 1; - pstate->fancyp = 1; - - /* First find out if it's reasonable to do indentation. */ - if (SCM_BACKWARDS_P) - indent_p = 0; - else - { - indent_p = 1; - frame = scm_stack_ref (stack, SCM_MAKINUM (beg)); - for (i = 0, j = 0; i < n; ++i) - { - if (SCM_FRAME_REAL_P (frame)) - ++j; - if (j > SCM_BACKTRACE_INDENT) - { - indent_p = 0; - break; - } - frame = (SCM_BACKWARDS_P - ? SCM_FRAME_PREV (frame) - : SCM_FRAME_NEXT (frame)); - } - } - - /* Determine size of frame number field. */ - j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end))); - for (i = 0; j > 0; ++i) j /= 10; - nfield = i ? i : 1; - - scm_gen_puts (scm_regular_string, "Backtrace:\n", port); - - /* Print frames. */ - frame = scm_stack_ref (stack, SCM_MAKINUM (beg)); - indentation = 1; - display_frame (frame, nfield, indentation, sport, port, pstate); - for (i = 1; i < n; ++i) - { - if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame)) - ++indentation; - frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame); - display_frame (frame, nfield, indentation, sport, port, pstate); - } - - return SCM_UNSPECIFIED; -} - - - -void -scm_init_backtrace () -{ -#include "backtrace.x" -} diff --git a/libguile/backtrace.h b/libguile/backtrace.h deleted file mode 100644 index 830a1eb2a..000000000 --- a/libguile/backtrace.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef BACKTRACEH -#define BACKTRACEH -/* Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - -void scm_display_error_message SCM_P ((SCM message, SCM args, SCM port)); -SCM scm_display_error SCM_P ((SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)); -SCM scm_display_backtrace SCM_P ((SCM stack, SCM port, SCM first, SCM depth)); - -void scm_init_backtrace SCM_P ((void)); - -#endif /* BACKTRACEH */ diff --git a/libguile/boolean.c b/libguile/boolean.c deleted file mode 100644 index 3267f28eb..000000000 --- a/libguile/boolean.c +++ /dev/null @@ -1,78 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "boolean.h" - - - -SCM_PROC(s_not, "not", 1, 0, 0, scm_not); - -SCM -scm_not(x) - SCM x; -{ - return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p); - -SCM -scm_boolean_p(obj) - SCM obj; -{ - if (SCM_BOOL_F==obj) return SCM_BOOL_T; - if (SCM_BOOL_T==obj) return SCM_BOOL_T; - return SCM_BOOL_F; -} - - - -void -scm_init_boolean () -{ -#include "boolean.x" -} - diff --git a/libguile/boolean.h b/libguile/boolean.h deleted file mode 100644 index c9945e566..000000000 --- a/libguile/boolean.h +++ /dev/null @@ -1,67 +0,0 @@ -/* classes: h_files */ - -#ifndef BOOLEANH -#define BOOLEANH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -/* Boolean Values - * - */ -#define SCM_FALSEP(x) (SCM_BOOL_F == (x)) -#define SCM_NFALSEP(x) (SCM_BOOL_F != (x)) - -/* SCM_BOOL_NOT returns the other boolean. - * The order of ^s here is important for Borland C++ (!?!?!) - */ -#define SCM_BOOL_NOT(x) ((x) ^ (SCM_BOOL_T ^ SCM_BOOL_F)) - - - -extern SCM scm_not SCM_P ((SCM x)); -extern SCM scm_boolean_p SCM_P ((SCM obj)); -extern void scm_init_boolean SCM_P ((void)); - -#endif /* BOOLEANH */ diff --git a/libguile/chars.c b/libguile/chars.c deleted file mode 100644 index cc77d3d09..000000000 --- a/libguile/chars.c +++ /dev/null @@ -1,408 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <ctype.h> -#include "_scm.h" - -#include "chars.h" - - - - -SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p); - -SCM -scm_char_p(x) - SCM x; -{ - return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p); - -SCM -scm_char_eq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p); - return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p); - -SCM -scm_char_less_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p); - return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p); - -SCM -scm_char_leq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p); - return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p); - -SCM -scm_char_gr_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p); - return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p); - -SCM -scm_char_geq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p); - return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p); - -SCM -scm_char_ci_eq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p); - return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p); - -SCM -scm_char_ci_less_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p); - return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p); - -SCM -scm_char_ci_leq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p); - return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p); - -SCM -scm_char_ci_gr_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p); - return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p); - -SCM -scm_char_ci_geq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p); - return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p); - -SCM -scm_char_alphabetic_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p); - return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p); - -SCM -scm_char_numeric_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p); - return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p); - -SCM -scm_char_whitespace_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p); - return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p); - -SCM -scm_char_upper_case_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p); - -SCM -scm_char_lower_case_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p); - return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p); - -SCM -scm_char_is_both_p (chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr)))) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - -SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer); - -SCM -scm_char_to_integer(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer); - return scm_ulong2num((unsigned long)SCM_ICHR(chr)); -} - - - -SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char); - -SCM -scm_integer_to_char(n) - SCM n; -{ - unsigned long ni; - - ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char); - return SCM_MAKICHR(SCM_INUM(n)); -} - - -SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase); - -SCM -scm_char_upcase(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase); - return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr))); -} - - -SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase); - -SCM -scm_char_downcase(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase); - return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr))); -} - - - - - -static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT]; -static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT]; -static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz"; -static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - - -void -scm_tables_prehistory () -{ - int i; - for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++) - scm_upcase_table[i] = scm_downcase_table[i] = i; - for (i = 0; i < sizeof scm_lowers / sizeof (char); i++) - { - scm_upcase_table[scm_lowers[i]] = scm_uppers[i]; - scm_downcase_table[scm_uppers[i]] = scm_lowers[i]; - } -} - - -int -scm_upcase (c) - unsigned int c; -{ - if (c < sizeof (scm_upcase_table)) - return scm_upcase_table[c]; - else - return c; -} - - -int -scm_downcase (c) - unsigned int c; -{ - if (c < sizeof (scm_downcase_table)) - return scm_downcase_table[c]; - else - return c; -} - - -#ifdef _DCC -# define ASCII -#else -# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) -# define EBCDIC -# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */ -# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) -# define ASCII -# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */ -#endif /* def _DCC */ - - -#ifdef EBCDIC -char *scm_charnames[] = -{ - "nul","soh","stx","etx", "pf", "ht", "lc","del", - 0 , 0 ,"smm", "vt", "ff", "cr", "so", "si", - "dle","dc1","dc2","dc3","res", "nl", "bs", "il", - "can", "em", "cc", 0 ,"ifs","igs","irs","ius", - "ds","sos", "fs", 0 ,"byp", "lf","eob","pre", - 0 , 0 , "sm", 0 , 0 ,"enq","ack","bel", - 0 , 0 ,"syn", 0 , "pn", "rs", "uc","eot", - 0 , 0 , 0 , 0 ,"dc4","nak", 0 ,"sub", - "space", scm_s_newline, "tab", "backspace", "return", "page", "null"}; - -char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ -\040\041\042\043\044\045\046\047\ -\050\051\052\053\054\055\056\057\ -\060\061\062\063\064\065\066\067\ -\070\071\072\073\074\075\076\077\ - \n\t\b\r\f\0"; -#endif /* def EBCDIC */ -#ifdef ASCII -char *scm_charnames[] = -{ - "nul","soh","stx","etx","eot","enq","ack","bel", - "bs", "ht", "nl", "vt", "np", "cr", "so", "si", - "dle","dc1","dc2","dc3","dc4","nak","syn","etb", - "can", "em","sub","esc", "fs", "gs", "rs", "us", - "space", "newline", "tab", "backspace", "return", "page", "null", "del"}; -char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ - \n\t\b\r\f\0\177"; -#endif /* def ASCII */ - -int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *); - - - - - -void -scm_init_chars () -{ -#include "chars.x" -} - diff --git a/libguile/chars.h b/libguile/chars.h deleted file mode 100644 index 8ad7672d3..000000000 --- a/libguile/chars.h +++ /dev/null @@ -1,90 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_CHARSH -#define SCM_CHARSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -/* Immediate Characters - */ -#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char) -#define SCM_ICHR(x) ((unsigned int)SCM_ITAG8_DATA(x)) -#define SCM_MAKICHR(x) SCM_MAKE_ITAG8(x, scm_tc8_char) - - - -extern char *scm_charnames[]; -extern int scm_n_charnames; -extern char scm_charnums[]; - - - -extern SCM scm_char_p SCM_P ((SCM x)); -extern SCM scm_char_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_alphabetic_p SCM_P ((SCM chr)); -extern SCM scm_char_numeric_p SCM_P ((SCM chr)); -extern SCM scm_char_whitespace_p SCM_P ((SCM chr)); -extern SCM scm_char_upper_case_p SCM_P ((SCM chr)); -extern SCM scm_char_lower_case_p SCM_P ((SCM chr)); -extern SCM scm_char_is_both_p SCM_P ((SCM chr)); -extern SCM scm_char_to_integer SCM_P ((SCM chr)); -extern SCM scm_integer_to_char SCM_P ((SCM n)); -extern SCM scm_char_upcase SCM_P ((SCM chr)); -extern SCM scm_char_downcase SCM_P ((SCM chr)); -extern void scm_tables_prehistory SCM_P ((void)); -extern int scm_upcase SCM_P ((unsigned int c)); -extern int scm_downcase SCM_P ((unsigned int c)); -extern void scm_init_chars SCM_P ((void)); - -#endif /* SCM_CHARSH */ diff --git a/libguile/configure b/libguile/configure deleted file mode 100755 index e156c59b0..000000000 --- a/libguile/configure +++ /dev/null @@ -1,3057 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.12 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: -ac_help="$ac_help - --disable-debug Don't include debugging support" -ac_help="$ac_help - --enable-dynamic-linking Include support for dynamic linking" -ac_help="$ac_help - --with-threads thread interface" - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.12" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=eval.c - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - - - - -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:561: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - for ac_prog in ginstall installbsd scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - # OSF/1 installbsd also uses dspmsg, but is usable. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - - -. $srcdir/../GUILE-VERSION - -PACKAGE=$PACKAGE - -cat >> confdefs.h <<EOF -#define PACKAGE "$PACKAGE" -EOF - -VERSION=$VERSION - -cat >> confdefs.h <<EOF -#define VERSION "$VERSION" -EOF - -echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 -echo "configure:629: checking whether build environment is sane" >&5 -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) -then - # Ok. - : -else - { echo "configure: error: newly created file is older than distributed files! -Check your system clock" 1>&2; exit 1; } -fi -rm -f conftest* -echo "$ac_t""yes" 1>&6 -if test "$program_transform_name" = s,x,x,; then - program_transform_name= -else - # Double any \ or $. echo might interpret backslashes. - cat <<\EOF_SED > conftestsed -s,\\,\\\\,g; s,\$,$$,g -EOF_SED - program_transform_name="`echo $program_transform_name|sed -f conftestsed`" - rm -f conftestsed -fi -test "$program_prefix" != NONE && - program_transform_name="s,^,${program_prefix},; $program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" - -# sed with no file args requires a program. -test "$program_transform_name" = "" && program_transform_name="s,x,x," - -echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:663: checking whether ${MAKE-make} sets \${MAKE}" >&5 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftestmake <<\EOF -all: - @echo 'ac_maketemp="${MAKE}"' -EOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi -rm -f conftestmake -fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then - echo "$ac_t""yes" 1>&6 - SET_MAKE= -else - echo "$ac_t""no" 1>&6 - SET_MAKE="MAKE=${MAKE-make}" -fi - -ac_aux_dir= -for ac_dir in .. $srcdir/..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -module=libguile - - -#-------------------------------------------------------------------- -# -# User options -# -#-------------------------------------------------------------------- - -# Check whether --enable-debug or --disable-debug was given. -if test "${enable_debug+set}" = set; then - enableval="$enable_debug" - : -fi - -if test "$enableval" != n && test "$enableval" != no; then - cat >> confdefs.h <<\EOF -#define DEBUG_EXTENSIONS 1 -EOF - - cat >> confdefs.h <<\EOF -#define READER_EXTENSIONS 1 -EOF - - LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS" -fi - -# Check whether --enable-dynamic-linking or --disable-dynamic-linking was given. -if test "${enable_dynamic_linking+set}" = set; then - enableval="$enable_dynamic_linking" - : -fi - -if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then - cat >> confdefs.h <<\EOF -#define DYNAMIC_LINKING 1 -EOF - -fi - -#-------------------------------------------------------------------- - -# Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:753: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_CC="gcc" - break - fi - done - IFS="$ac_save_ifs" -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:782: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - ac_prog_rejected=no - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - break - fi - done - IFS="$ac_save_ifs" -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# -gt 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - set dummy "$ac_dir/$ac_word" "$@" - shift - ac_cv_prog_CC="$@" - fi -fi -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } -fi - -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:830: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -cat > conftest.$ac_ext <<EOF -#line 840 "configure" -#include "confdefs.h" -main(){return(0);} -EOF -if { (eval echo configure:844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - ac_cv_prog_cc_works=yes - # If we can't run a trivial program, we are probably using a cross compiler. - if (./conftest; exit) 2>/dev/null; then - ac_cv_prog_cc_cross=no - else - ac_cv_prog_cc_cross=yes - fi -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - ac_cv_prog_cc_works=no -fi -rm -fr conftest* - -echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 -if test $ac_cv_prog_cc_works = no; then - { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } -fi -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:864: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 -echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 -cross_compiling=$ac_cv_prog_cc_cross - -echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:869: checking whether we are using GNU C" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.c <<EOF -#ifdef __GNUC__ - yes; -#endif -EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:878: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then - ac_cv_prog_gcc=yes -else - ac_cv_prog_gcc=no -fi -fi - -echo "$ac_t""$ac_cv_prog_gcc" 1>&6 - -if test $ac_cv_prog_gcc = yes; then - GCC=yes - ac_test_CFLAGS="${CFLAGS+set}" - ac_save_CFLAGS="$CFLAGS" - CFLAGS= - echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:893: checking whether ${CC-cc} accepts -g" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - echo 'void f(){}' > conftest.c -if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then - ac_cv_prog_cc_g=yes -else - ac_cv_prog_cc_g=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 - if test "$ac_test_CFLAGS" = set; then - CFLAGS="$ac_save_CFLAGS" - elif test $ac_cv_prog_cc_g = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-O2" - fi -else - GCC= - test "${CFLAGS+set}" = set || CFLAGS="-g" -fi - -echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:921: checking how to run the C preprocessor" >&5 -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then -if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - # This must be in double quotes, not single quotes, because CPP may get - # substituted into the Makefile and "${CC-cc}" will confuse make. - CPP="${CC-cc} -E" - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. - cat > conftest.$ac_ext <<EOF -#line 936 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:942: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP="${CC-cc} -E -traditional-cpp" - cat > conftest.$ac_ext <<EOF -#line 953 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:959: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP=/lib/cpp -fi -rm -f conftest* -fi -rm -f conftest* - ac_cv_prog_CPP="$CPP" -fi - CPP="$ac_cv_prog_CPP" -else - ac_cv_prog_CPP="$CPP" -fi -echo "$ac_t""$CPP" 1>&6 - -# Extract the first word of "ranlib", so it can be a program name with args. -set dummy ranlib; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:984: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$RANLIB"; then - ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_RANLIB="ranlib" - break - fi - done - IFS="$ac_save_ifs" - test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" -fi -fi -RANLIB="$ac_cv_prog_RANLIB" -if test -n "$RANLIB"; then - echo "$ac_t""$RANLIB" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - -echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:1012: checking for AIX" >&5 -cat > conftest.$ac_ext <<EOF -#line 1014 "configure" -#include "confdefs.h" -#ifdef _AIX - yes -#endif - -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "yes" >/dev/null 2>&1; then - rm -rf conftest* - echo "$ac_t""yes" 1>&6; cat >> confdefs.h <<\EOF -#define _ALL_SOURCE 1 -EOF - -else - rm -rf conftest* - echo "$ac_t""no" 1>&6 -fi -rm -f conftest* - - -echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6 -echo "configure:1036: checking for POSIXized ISC" >&5 -if test -d /etc/conf/kconfig.d && - grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 -then - echo "$ac_t""yes" 1>&6 - ISC=yes # If later tests want to check for ISC. - cat >> confdefs.h <<\EOF -#define _POSIX_SOURCE 1 -EOF - - if test "$GCC" = yes; then - CC="$CC -posix" - else - CC="$CC -Xp" - fi -else - echo "$ac_t""no" 1>&6 - ISC= -fi - -ac_safe=`echo "minix/config.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for minix/config.h""... $ac_c" 1>&6 -echo "configure:1058: checking for minix/config.h" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1063 "configure" -#include "confdefs.h" -#include <minix/config.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1068: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - MINIX=yes -else - echo "$ac_t""no" 1>&6 -MINIX= -fi - -if test "$MINIX" = yes; then - cat >> confdefs.h <<\EOF -#define _POSIX_SOURCE 1 -EOF - - cat >> confdefs.h <<\EOF -#define _POSIX_1_SOURCE 2 -EOF - - cat >> confdefs.h <<\EOF -#define _MINIX 1 -EOF - -fi - - - -echo $ac_n "checking "threads package type"""... $ac_c" 1>&6 -echo "configure:1108: checking "threads package type"" >&5 -if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -use_threads=no; -# Check whether --with-threads or --without-threads was given. -if test "${with_threads+set}" = set; then - withval="$with_threads" - use_threads=$withval -else - use_threads=no -fi - -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - cat > conftest.$ac_ext <<EOF -#line 1167 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=FSU -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthread" - cat > conftest.$ac_ext <<EOF -#line 1188 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1197: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=MIT -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthreads" - cat > conftest.$ac_ext <<EOF -#line 1209 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1218: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=PCthreads -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; } - fi -fi - -fi - - -fi - - -fi - -echo "$ac_t""$cy_cv_threads_package" 1>&6 - - -echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:1250: checking for working const" >&5 -if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1255 "configure" -#include "confdefs.h" - -int main() { - -/* Ultrix mips cc rejects this. */ -typedef int charset[2]; const charset x; -/* SunOS 4.1.1 cc rejects this. */ -char const *const *ccp; -char **p; -/* NEC SVR4.0.2 mips cc rejects this. */ -struct point {int x, y;}; -static struct point const zero = {0,0}; -/* AIX XL C 1.02.0.0 rejects this. - It does not let you subtract one const X* pointer from another in an arm - of an if-expression whose if-part is not a constant expression */ -const char *g = "string"; -ccp = &g + (g ? g-g : 0); -/* HPUX 7.0 cc rejects these. */ -++ccp; -p = (char**) ccp; -ccp = (char const *const *) p; -{ /* SCO 3.2v4 cc rejects this. */ - char *t; - char const *s = 0 ? (char *) 0 : (char const *) 0; - - *t++ = 0; -} -{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ - int x[] = {25, 17}; - const int *foo = &x[0]; - ++foo; -} -{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ - typedef const int *iptr; - iptr p = 0; - ++p; -} -{ /* AIX XL C 1.02.0.0 rejects this saying - "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ - struct s { int j; const int *ap[3]; }; - struct s *b; b->j = 5; -} -{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ - const int foo = 10; -} - -; return 0; } -EOF -if { (eval echo configure:1304: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_c_const=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_c_const=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_c_const" 1>&6 -if test $ac_cv_c_const = no; then - cat >> confdefs.h <<\EOF -#define const -EOF - -fi - - -echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:1326: checking for ANSI C header files" >&5 -if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1331 "configure" -#include "confdefs.h" -#include <stdlib.h> -#include <stdarg.h> -#include <string.h> -#include <float.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1339: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - ac_cv_header_stdc=yes -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. -cat > conftest.$ac_ext <<EOF -#line 1356 "configure" -#include "confdefs.h" -#include <string.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "memchr" >/dev/null 2>&1; then - : -else - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. -cat > conftest.$ac_ext <<EOF -#line 1374 "configure" -#include "confdefs.h" -#include <stdlib.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "free" >/dev/null 2>&1; then - : -else - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. -if test "$cross_compiling" = yes; then - : -else - cat > conftest.$ac_ext <<EOF -#line 1395 "configure" -#include "confdefs.h" -#include <ctype.h> -#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int main () { int i; for (i = 0; i < 256; i++) -if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); -exit (0); } - -EOF -if { (eval echo configure:1406: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - : -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -fr conftest* - ac_cv_header_stdc=no -fi -rm -fr conftest* -fi - -fi -fi - -echo "$ac_t""$ac_cv_header_stdc" 1>&6 -if test $ac_cv_header_stdc = yes; then - cat >> confdefs.h <<\EOF -#define STDC_HEADERS 1 -EOF - -fi - -ac_header_dirent=no -for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6 -echo "configure:1434: checking for $ac_hdr that defines DIR" >&5 -if eval "test \"`echo '$''{'ac_cv_header_dirent_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1439 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <$ac_hdr> -int main() { -DIR *dirp = 0; -; return 0; } -EOF -if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - eval "ac_cv_header_dirent_$ac_safe=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_dirent_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_dirent_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - ac_header_dirent=$ac_hdr; break -else - echo "$ac_t""no" 1>&6 -fi -done -# Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. -if test $ac_header_dirent = dirent.h; then -echo $ac_n "checking for opendir in -ldir""... $ac_c" 1>&6 -echo "configure:1472: checking for opendir in -ldir" >&5 -ac_lib_var=`echo dir'_'opendir | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldir $LIBS" -cat > conftest.$ac_ext <<EOF -#line 1480 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char opendir(); - -int main() { -opendir() -; return 0; } -EOF -if { (eval echo configure:1491: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - LIBS="$LIBS -ldir" -else - echo "$ac_t""no" 1>&6 -fi - -else -echo $ac_n "checking for opendir in -lx""... $ac_c" 1>&6 -echo "configure:1513: checking for opendir in -lx" >&5 -ac_lib_var=`echo x'_'opendir | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-lx $LIBS" -cat > conftest.$ac_ext <<EOF -#line 1521 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char opendir(); - -int main() { -opendir() -; return 0; } -EOF -if { (eval echo configure:1532: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - LIBS="$LIBS -lx" -else - echo "$ac_t""no" 1>&6 -fi - -fi - -echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:1555: checking whether time.h and sys/time.h may both be included" >&5 -if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1560 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/time.h> -#include <time.h> -int main() { -struct tm *tp; -; return 0; } -EOF -if { (eval echo configure:1569: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_header_time=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_time=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_header_time" 1>&6 -if test $ac_cv_header_time = yes; then - cat >> confdefs.h <<\EOF -#define TIME_WITH_SYS_TIME 1 -EOF - -fi - -echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:1590: checking for sys/wait.h that is POSIX.1 compatible" >&5 -if eval "test \"`echo '$''{'ac_cv_header_sys_wait_h'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1595 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/wait.h> -#ifndef WEXITSTATUS -#define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) -#endif -#ifndef WIFEXITED -#define WIFEXITED(stat_val) (((stat_val) & 255) == 0) -#endif -int main() { -int s; -wait (&s); -s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; -; return 0; } -EOF -if { (eval echo configure:1611: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_header_sys_wait_h=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_sys_wait_h=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_header_sys_wait_h" 1>&6 -if test $ac_cv_header_sys_wait_h = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_SYS_WAIT_H 1 -EOF - -fi - -for ac_hdr in libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:1635: checking for $ac_hdr" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1640 "configure" -#include "confdefs.h" -#include <$ac_hdr> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - - for ac_hdr in libc.h unistd.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:1676: checking for $ac_hdr" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1681 "configure" -#include "confdefs.h" -#include <$ac_hdr> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1686: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - echo $ac_n "checking "whether libc.h and unistd.h can be included together"""... $ac_c" 1>&6 -echo "configure:1713: checking "whether libc.h and unistd.h can be included together"" >&5 -if eval "test \"`echo '$''{'guile_cv_header_libc_with_unistd'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - - if test "$ac_cv_header_libc_h" = "no"; then - guile_cv_header_libc_with_unistd="no" - elif test "$ac_cv_header_unistd.h" = "no"; then - guile_cv_header_libc_with_unistd="yes" - else - cat > conftest.$ac_ext <<EOF -#line 1724 "configure" -#include "confdefs.h" - -# include <libc.h> -# include <unistd.h> - -int main() { - -; return 0; } -EOF -if { (eval echo configure:1734: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - guile_cv_header_libc_with_unistd=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - guile_cv_header_libc_with_unistd=no - -fi -rm -f conftest* - fi - - -fi - -echo "$ac_t""$guile_cv_header_libc_with_unistd" 1>&6 - if test "$guile_cv_header_libc_with_unistd" = yes; then - cat >> confdefs.h <<\EOF -#define LIBC_H_WITH_UNISTD_H 1 -EOF - - fi - - - -echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:1761: checking for uid_t in sys/types.h" >&5 -if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1766 "configure" -#include "confdefs.h" -#include <sys/types.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "uid_t" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_uid_t=yes -else - rm -rf conftest* - ac_cv_type_uid_t=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$ac_cv_type_uid_t" 1>&6 -if test $ac_cv_type_uid_t = no; then - cat >> confdefs.h <<\EOF -#define uid_t int -EOF - - cat >> confdefs.h <<\EOF -#define gid_t int -EOF - -fi - -echo $ac_n "checking type of array argument to getgroups""... $ac_c" 1>&6 -echo "configure:1795: checking type of array argument to getgroups" >&5 -if eval "test \"`echo '$''{'ac_cv_type_getgroups'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test "$cross_compiling" = yes; then - ac_cv_type_getgroups=cross -else - cat > conftest.$ac_ext <<EOF -#line 1803 "configure" -#include "confdefs.h" - -/* Thanks to Mike Rendell for this test. */ -#include <sys/types.h> -#define NGID 256 -#undef MAX -#define MAX(x, y) ((x) > (y) ? (x) : (y)) -main() -{ - gid_t gidset[NGID]; - int i, n; - union { gid_t gval; long lval; } val; - - val.lval = -1; - for (i = 0; i < NGID; i++) - gidset[i] = val.gval; - n = getgroups (sizeof (gidset) / MAX (sizeof (int), sizeof (gid_t)) - 1, - gidset); - /* Exit non-zero if getgroups seems to require an array of ints. This - happens when gid_t is short but getgroups modifies an array of ints. */ - exit ((n > 0 && gidset[n] != val.gval) ? 1 : 0); -} - -EOF -if { (eval echo configure:1828: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - ac_cv_type_getgroups=gid_t -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -fr conftest* - ac_cv_type_getgroups=int -fi -rm -fr conftest* -fi - -if test $ac_cv_type_getgroups = cross; then - cat > conftest.$ac_ext <<EOF -#line 1842 "configure" -#include "confdefs.h" -#include <unistd.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "getgroups.*int.*gid_t" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_getgroups=gid_t -else - rm -rf conftest* - ac_cv_type_getgroups=int -fi -rm -f conftest* - -fi -fi - -echo "$ac_t""$ac_cv_type_getgroups" 1>&6 -cat >> confdefs.h <<EOF -#define GETGROUPS_T $ac_cv_type_getgroups -EOF - - -echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:1866: checking return type of signal handlers" >&5 -if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1871 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <signal.h> -#ifdef signal -#undef signal -#endif -#ifdef __cplusplus -extern "C" void (*signal (int, void (*)(int)))(int); -#else -void (*signal ()) (); -#endif - -int main() { -int i; -; return 0; } -EOF -if { (eval echo configure:1888: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_type_signal=void -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_type_signal=int -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_type_signal" 1>&6 -cat >> confdefs.h <<EOF -#define RETSIGTYPE $ac_cv_type_signal -EOF - - -echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:1907: checking for mode_t" >&5 -if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1912 "configure" -#include "confdefs.h" -#include <sys/types.h> -#if STDC_HEADERS -#include <stdlib.h> -#include <stddef.h> -#endif -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_mode_t=yes -else - rm -rf conftest* - ac_cv_type_mode_t=no -fi -rm -f conftest* - -fi -echo "$ac_t""$ac_cv_type_mode_t" 1>&6 -if test $ac_cv_type_mode_t = no; then - cat >> confdefs.h <<\EOF -#define mode_t int -EOF - -fi - - -for ac_func in ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:1943: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1948 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:1971: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - -for ac_func in inet_aton strerror -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:1999: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2004 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:2027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -LIBOBJS="$LIBOBJS ${ac_func}.o" -fi -done - - - -echo $ac_n "checking for st_rdev in struct stat""... $ac_c" 1>&6 -echo "configure:2055: checking for st_rdev in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_rdev'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2060 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_rdev; -; return 0; } -EOF -if { (eval echo configure:2068: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_rdev=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_rdev=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_rdev" 1>&6 -if test $ac_cv_struct_st_rdev = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_RDEV 1 -EOF - -fi - -echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6 -echo "configure:2089: checking for st_blksize in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2094 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_blksize; -; return 0; } -EOF -if { (eval echo configure:2102: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_blksize=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_blksize=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6 -if test $ac_cv_struct_st_blksize = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_BLKSIZE 1 -EOF - -fi - -echo $ac_n "checking for st_blocks in struct stat""... $ac_c" 1>&6 -echo "configure:2123: checking for st_blocks in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_blocks'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2128 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_blocks; -; return 0; } -EOF -if { (eval echo configure:2136: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_blocks=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_blocks=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_blocks" 1>&6 -if test $ac_cv_struct_st_blocks = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_BLOCKS 1 -EOF - -else - LIBOBJS="$LIBOBJS fileblocks.o" -fi - - - echo $ac_n "checking whether we need POSIX to get struct utimbuf""... $ac_c" 1>&6 -echo "configure:2160: checking whether we need POSIX to get struct utimbuf" >&5 -if eval "test \"`echo '$''{'guile_cv_struct_utimbuf_needs_posix'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2165 "configure" -#include "confdefs.h" - -#ifdef __EMX__ -#include <sys/utime.h> -#else -#include <utime.h> -#endif -struct utime blah; - -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2177: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - guile_cv_struct_utimbuf_needs_posix=no -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - guile_cv_struct_utimbuf_needs_posix=yes -fi -rm -f conftest* -fi - -echo "$ac_t""$guile_cv_struct_utimbuf_needs_posix" 1>&6 - if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then - cat >> confdefs.h <<\EOF -#define UTIMBUF_NEEDS_POSIX 1 -EOF - - fi - -# Checks for dynamic linking -echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 -echo "configure:2202: checking for dlopen in -ldl" >&5 -ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldl $LIBS" -cat > conftest.$ac_ext <<EOF -#line 2210 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char dlopen(); - -int main() { -dlopen() -; return 0; } -EOF -if { (eval echo configure:2221: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_lib=HAVE_LIB`echo dl | sed -e 's/[^a-zA-Z0-9_]/_/g' \ - -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` - cat >> confdefs.h <<EOF -#define $ac_tr_lib 1 -EOF - - LIBS="-ldl $LIBS" - -else - echo "$ac_t""no" 1>&6 -fi - -echo $ac_n "checking for dld_link in -ldld""... $ac_c" 1>&6 -echo "configure:2249: checking for dld_link in -ldld" >&5 -ac_lib_var=`echo dld'_'dld_link | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldld $LIBS" -cat > conftest.$ac_ext <<EOF -#line 2257 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char dld_link(); - -int main() { -dld_link() -; return 0; } -EOF -if { (eval echo configure:2268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_lib=HAVE_LIB`echo dld | sed -e 's/[^a-zA-Z0-9_]/_/g' \ - -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` - cat >> confdefs.h <<EOF -#define $ac_tr_lib 1 -EOF - - LIBS="-ldld $LIBS" - -else - echo "$ac_t""no" 1>&6 -fi - -for ac_func in shl_load -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:2298: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2303 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:2326: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - -#-------------------------------------------------------------------- -# -# Which way does the stack grow? -# -#-------------------------------------------------------------------- - -if test "$cross_compiling" = yes; then - echo "configure: warning: Guessing that stack grows down -- see scmconfig.h.in" 1>&2 -else - cat > conftest.$ac_ext <<EOF -#line 2361 "configure" -#include "confdefs.h" -aux (l) unsigned long l; - { int x; exit (l >= ((unsigned long)&x)); } - main () { int q; aux((unsigned long)&q); } -EOF -if { (eval echo configure:2367: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - cat >> confdefs.h <<\EOF -#define SCM_STACK_GROWS_UP 1 -EOF - -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -fr conftest* -fi - - - -if test "$cross_compiling" = yes; then - cat >> confdefs.h <<\EOF -#define SCM_SINGLES 1 -EOF - - echo "configure: warning: Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in" 1>&2 -else - cat > conftest.$ac_ext <<EOF -#line 2390 "configure" -#include "confdefs.h" -main () { exit (sizeof(float) != sizeof(long)); } -EOF -if { (eval echo configure:2394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - cat >> confdefs.h <<\EOF -#define SCM_SINGLES 1 -EOF - -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -fr conftest* -fi - - -echo $ac_n "checking for struct linger""... $ac_c" 1>&6 -echo "configure:2409: checking for struct linger" >&5 -if eval "test \"`echo '$''{'scm_cv_struct_linger'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2414 "configure" -#include "confdefs.h" -#include <sys/socket.h> -int main() { -struct linger lgr; lgr.l_linger = 100 -; return 0; } -EOF -if { (eval echo configure:2421: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_linger="yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_linger="no" -fi -rm -f conftest* -fi - -echo "$ac_t""$scm_cv_struct_linger" 1>&6 -if test $scm_cv_struct_linger = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_STRUCT_LINGER 1 -EOF - -fi - -#-------------------------------------------------------------------- -# -# How can you violate a stdio abstraction by setting a stream's fd? -# -#-------------------------------------------------------------------- - -FD_SETTER="" - -if test "x$FD_SETTER" = x; then - cat > conftest.$ac_ext <<EOF -#line 2451 "configure" -#include "confdefs.h" -#include <stdio.h> - -int main() { -stdout->_file = 1 -; return 0; } -EOF -if { (eval echo configure:2459: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - FD_SETTER="((F)->_file = (D))" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - -if test "x$FD_SETTER" = x; then - cat > conftest.$ac_ext <<EOF -#line 2471 "configure" -#include "confdefs.h" -#include <stdio.h> - -int main() { -stdout->_fileno -; return 0; } -EOF -if { (eval echo configure:2479: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - FD_SETTER="((F)->_fileno = (D))" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - - -test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF -#define HAVE_FD_SETTER 1 -EOF - - -#-------------------------------------------------------------------- -# How to find out whether a FILE structure contains buffered data. -# From Tk we have the following list: -# _cnt: Most UNIX systems -# __cnt: HPUX -# _r: BSD -# readCount: Sprite -# Or, in GNU libc there are two fields, _gptr and _egptr, which -# have to be compared. -# These can also be known as _IO_read_ptr and _IO_read_end. -#-------------------------------------------------------------------- - -echo $ac_n "checking how to get buffer char count from FILE structure""... $ac_c" 1>&6 -echo "configure:2508: checking how to get buffer char count from FILE structure" >&5 -if eval "test \"`echo '$''{'scm_cv_struct_file_count'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2513 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_cnt = 0 -; return 0; } -EOF -if { (eval echo configure:2520: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="_cnt" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - cat > conftest.$ac_ext <<EOF -#line 2528 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_r = 0 -; return 0; } -EOF -if { (eval echo configure:2535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="_r" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - cat > conftest.$ac_ext <<EOF -#line 2543 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->readCount = 0 -; return 0; } -EOF -if { (eval echo configure:2550: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="readCount" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_file_count="" -fi -rm -f conftest* -fi -rm -f conftest* -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_file_count"; then - echo "$ac_t""$scm_cv_struct_file_count" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_FIELD $scm_cv_struct_file_count -EOF - -else -if eval "test \"`echo '$''{'scm_cv_struct_file_gptr'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2577 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_gptr = f->egptr; -; return 0; } -EOF -if { (eval echo configure:2584: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_gptr=1 -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_file_gptr="" -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_gptr"; then - echo "$ac_t""gptr" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_GPTR $scm_cv_struct_file_gptr -EOF - -else -if eval "test \"`echo '$''{'scm_cv_struct_file_readptr'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2607 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end; -; return 0; } -EOF -if { (eval echo configure:2614: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_readptr=1 -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_file_readptr"; then - echo "$ac_t""read_ptr" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_READPTR $scm_cv_struct_file_readptr -EOF - -fi -fi -fi - -#-------------------------------------------------------------------- -# -# Flags for thread support -# -#-------------------------------------------------------------------- - -if test "$cy_cv_threads_package" = FSU; then - cat >> confdefs.h <<\EOF -#define USE_FSU_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = COOP; then - cat >> confdefs.h <<\EOF -#define USE_COOP_THREADS 1 -EOF - - else if test "$cy_cv_threads_package" = MIT; then - cat >> confdefs.h <<\EOF -#define USE_MIT_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = PCthreads; then - cat >> confdefs.h <<\EOF -#define USE_PCTHREADS_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = unknown; then - { echo "configure: error: "cannot find threads installation"" 1>&2; exit 1; } - fi - fi - fi - fi -fi - -if test "$cy_cv_threads_package" != ""; then - cat >> confdefs.h <<\EOF -#define USE_THREADS 1 -EOF - -fi - -## If we're using GCC, ask for aggressive warnings. -case "$GCC" in - yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;; -esac - -cat >> confdefs.h <<EOF -#define GUILE_MAJOR_VERSION "$GUILE_MAJOR_VERSION" -EOF - -cat >> confdefs.h <<EOF -#define GUILE_MINOR_VERSION "$GUILE_MINOR_VERSION" -EOF - -cat >> confdefs.h <<EOF -#define GUILE_VERSION "$GUILE_VERSION" -EOF - - - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -DEFS=-DHAVE_CONFIG_H - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS <<EOF -#! /bin/sh -# Generated automatically by configure. -# Run this file to recreate the current configuration. -# This directory was configured as follows, -# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.12" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" - -trap 'rm -fr `echo "Makefile fd.h guile-snarf scmconfig.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS <<EOF - -# Protect against being on the right side of a sed subst in config.status. -sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; - s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_DATA@%$INSTALL_DATA%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g -s%@SET_MAKE@%$SET_MAKE%g -s%@module@%$module%g -s%@CC@%$CC%g -s%@CPP@%$CPP%g -s%@RANLIB@%$RANLIB%g -s%@LIBOBJS@%$LIBOBJS%g -s%@FD_SETTER@%$FD_SETTER%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <<EOF - -CONFIG_FILES=\${CONFIG_FILES-"Makefile fd.h guile-snarf"} -EOF -cat >> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where -# NAME is the cpp macro being defined and VALUE is the value it is being given. -# -# ac_d sets the value in "#define NAME VALUE" lines. -ac_dA='s%^\([ ]*\)#\([ ]*define[ ][ ]*\)' -ac_dB='\([ ][ ]*\)[^ ]*%\1#\2' -ac_dC='\3' -ac_dD='%g' -# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE". -ac_uA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' -ac_uB='\([ ]\)%\1#\2define\3' -ac_uC=' ' -ac_uD='\4%g' -# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE". -ac_eA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' -ac_eB='$%\1#\2define\3' -ac_eC=' ' -ac_eD='%g' - -if test "${CONFIG_HEADERS+set}" != set; then -EOF -cat >> $CONFIG_STATUS <<EOF - CONFIG_HEADERS="scmconfig.h" -EOF -cat >> $CONFIG_STATUS <<\EOF -fi -for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - echo creating $ac_file - - rm -f conftest.frag conftest.in conftest.out - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - cat $ac_file_inputs > conftest.in - -EOF - -# Transform confdefs.h into a sed script conftest.vals that substitutes -# the proper values into config.h.in to produce config.h. And first: -# Protect against being on the right side of a sed subst in config.status. -# Protect against being in an unquoted here document in config.status. -rm -f conftest.vals -cat > conftest.hdr <<\EOF -s/[\\&%]/\\&/g -s%[\\$`]%\\&%g -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp -s%ac_d%ac_u%gp -s%ac_u%ac_e%gp -EOF -sed -n -f conftest.hdr confdefs.h > conftest.vals -rm -f conftest.hdr - -# This sed command replaces #undef with comments. This is necessary, for -# example, in the case of _POSIX_SOURCE, which is predefined and required -# on some systems where configure will not decide to define it. -cat >> conftest.vals <<\EOF -s%^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */% -EOF - -# Break up conftest.vals because some shells have a limit on -# the size of here documents, and old seds have small limits too. - -rm -f conftest.tail -while : -do - ac_lines=`grep -c . conftest.vals` - # grep -c gives empty output for an empty file on some AIX systems. - if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi - # Write a limited-size here document to conftest.frag. - echo ' cat > conftest.frag <<CEOF' >> $CONFIG_STATUS - sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS - echo 'CEOF - sed -f conftest.frag conftest.in > conftest.out - rm -f conftest.in - mv conftest.out conftest.in -' >> $CONFIG_STATUS - sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail - rm -f conftest.vals - mv conftest.tail conftest.vals -done -rm -f conftest.vals - -cat >> $CONFIG_STATUS <<\EOF - rm -f conftest.frag conftest.h - echo "/* $ac_file. Generated automatically by configure. */" > conftest.h - cat conftest.in >> conftest.h - rm -f conftest.in - if cmp -s $ac_file conftest.h 2>/dev/null; then - echo "$ac_file is unchanged" - rm -f conftest.h - else - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - fi - rm -f $ac_file - mv conftest.h $ac_file - fi -fi; done - -EOF -cat >> $CONFIG_STATUS <<EOF - - -EOF -cat >> $CONFIG_STATUS <<\EOF -test -z "$CONFIG_HEADER" || echo timestamp > stamp-h -chmod +x guile-snarf -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - - diff --git a/libguile/configure.in b/libguile/configure.in deleted file mode 100644 index d7ba37bd3..000000000 --- a/libguile/configure.in +++ /dev/null @@ -1,218 +0,0 @@ -AC_INIT(eval.c) -AM_CONFIG_HEADER(scmconfig.h) -AM_INIT_GUILE_MODULE(libguile) - -#-------------------------------------------------------------------- -# -# User options -# -#-------------------------------------------------------------------- - -AC_ARG_ENABLE(debug, -[ --disable-debug Don't include debugging support]) -if test "$enableval" != n && test "$enableval" != no; then - AC_DEFINE(DEBUG_EXTENSIONS) - AC_DEFINE(READER_EXTENSIONS) - LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS" -fi - -AC_ARG_ENABLE(dynamic-linking, - [ --enable-dynamic-linking Include support for dynamic linking]) -if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then - AC_DEFINE(DYNAMIC_LINKING) -fi - -#-------------------------------------------------------------------- - -AC_PROG_CC -AC_PROG_CPP -AC_PROG_RANLIB - -AC_AIX -AC_ISC_POSIX -AC_MINIX - -CY_AC_WITH_THREADS - -AC_C_CONST - -AC_HEADER_STDC -AC_HEADER_DIRENT -AC_HEADER_TIME -AC_HEADER_SYS_WAIT -AC_CHECK_HEADERS(libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h) -GUILE_HEADER_LIBC_WITH_UNISTD - -AC_TYPE_GETGROUPS -AC_TYPE_SIGNAL -AC_TYPE_MODE_T - -AC_CHECK_FUNCS(ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid) - -AC_REPLACE_FUNCS(inet_aton strerror) - -AC_STRUCT_ST_RDEV -AC_STRUCT_ST_BLKSIZE -AC_STRUCT_ST_BLOCKS -GUILE_STRUCT_UTIMBUF - -# Checks for dynamic linking -AC_CHECK_LIB(dl,dlopen) -AC_CHECK_LIB(dld,dld_link) -AC_CHECK_FUNCS(shl_load) - -#-------------------------------------------------------------------- -# -# Which way does the stack grow? -# -#-------------------------------------------------------------------- - -AC_TRY_RUN(aux (l) unsigned long l; - { int x; exit (l >= ((unsigned long)&x)); } - main () { int q; aux((unsigned long)&q); }, - AC_DEFINE(SCM_STACK_GROWS_UP),,AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h.in)) - - -AC_TRY_RUN(main () { exit (sizeof(float) != sizeof(long)); }, - AC_DEFINE(SCM_SINGLES),,AC_DEFINE(SCM_SINGLES) - AC_MSG_WARN(Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in)) - -AC_MSG_CHECKING(for struct linger) -AC_CACHE_VAL(scm_cv_struct_linger, - AC_TRY_COMPILE([#include <sys/socket.h>], - [struct linger lgr; lgr.l_linger = 100], - scm_cv_struct_linger="yes", - scm_cv_struct_linger="no")) -AC_MSG_RESULT($scm_cv_struct_linger) -if test $scm_cv_struct_linger = yes; then - AC_DEFINE(HAVE_STRUCT_LINGER) -fi - -#-------------------------------------------------------------------- -# -# How can you violate a stdio abstraction by setting a stream's fd? -# -#-------------------------------------------------------------------- - -FD_SETTER="" - -if test "x$FD_SETTER" = x; then - AC_TRY_COMPILE(#include <stdio.h> -, stdout->_file = 1, - FD_SETTER="((F)->_file = (D))") -fi - -if test "x$FD_SETTER" = x; then - AC_TRY_COMPILE(#include <stdio.h> -, stdout->_fileno, - FD_SETTER="((F)->_fileno = (D))") -fi - -dnl -dnl Add FD_SETTER tests for other systems here. Your test should -dnl try a particular style of assigning to the descriptor -dnl field(s) of a FILE* and define FD_SETTER accordingly. -dnl -dnl The value of FD_SETTER is used as a macro body, as in: -dnl -dnl #define SET_FILE_FD_FIELD(F,D) @FD_SETTER@ -dnl -dnl F is a FILE* and D a descriptor (int). -dnl - -test "x$FD_SETTER" != x && AC_DEFINE(HAVE_FD_SETTER) - -#-------------------------------------------------------------------- -# How to find out whether a FILE structure contains buffered data. -# From Tk we have the following list: -# _cnt: Most UNIX systems -# __cnt: HPUX -# _r: BSD -# readCount: Sprite -# Or, in GNU libc there are two fields, _gptr and _egptr, which -# have to be compared. -# These can also be known as _IO_read_ptr and _IO_read_end. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING(how to get buffer char count from FILE structure) -AC_CACHE_VAL(scm_cv_struct_file_count, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_cnt = 0], - scm_cv_struct_file_count="_cnt", - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_r = 0], - scm_cv_struct_file_count="_r", - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->readCount = 0], - scm_cv_struct_file_count="readCount", - scm_cv_struct_file_count="")))) -if test "$scm_cv_struct_file_count"; then - AC_MSG_RESULT($scm_cv_struct_file_count) - AC_DEFINE_UNQUOTED(FILE_CNT_FIELD, $scm_cv_struct_file_count) -else -AC_CACHE_VAL(scm_cv_struct_file_gptr, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_gptr = f->egptr;], - scm_cv_struct_file_gptr=1, - scm_cv_struct_file_gptr="")) -if test "$scm_cv_struct_gptr"; then - AC_MSG_RESULT(gptr) - AC_DEFINE_UNQUOTED(FILE_CNT_GPTR, $scm_cv_struct_file_gptr) -else -AC_CACHE_VAL(scm_cv_struct_file_readptr, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;], - scm_cv_struct_file_readptr=1)) -if test "$scm_cv_struct_file_readptr"; then - AC_MSG_RESULT(read_ptr) - AC_DEFINE_UNQUOTED(FILE_CNT_READPTR, $scm_cv_struct_file_readptr) -fi -fi -fi - -#-------------------------------------------------------------------- -# -# Flags for thread support -# -#-------------------------------------------------------------------- - -dnl -dnl Set the appropriate flags! -dnl -if test "$cy_cv_threads_package" = FSU; then - AC_DEFINE(USE_FSU_PTHREADS, 1) - else if test "$cy_cv_threads_package" = COOP; then - AC_DEFINE(USE_COOP_THREADS, 1) - else if test "$cy_cv_threads_package" = MIT; then - AC_DEFINE(USE_MIT_PTHREADS, 1) - else if test "$cy_cv_threads_package" = PCthreads; then - AC_DEFINE(USE_PCTHREADS_PTHREADS, 1) - else if test "$cy_cv_threads_package" = unknown; then - AC_MSG_ERROR("cannot find threads installation") - fi - fi - fi - fi -fi - -if test "$cy_cv_threads_package" != ""; then - AC_DEFINE(USE_THREADS) -fi - -## If we're using GCC, ask for aggressive warnings. -case "$GCC" in - yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;; -esac - -AC_DEFINE_UNQUOTED(GUILE_MAJOR_VERSION, "$GUILE_MAJOR_VERSION") -AC_DEFINE_UNQUOTED(GUILE_MINOR_VERSION, "$GUILE_MINOR_VERSION") -AC_DEFINE_UNQUOTED(GUILE_VERSION, "$GUILE_VERSION") - -AC_SUBST(FD_SETTER) -AC_OUTPUT([Makefile fd.h guile-snarf], [chmod +x guile-snarf]) - -dnl Local Variables: -dnl comment-start: "dnl " -dnl comment-end: "" -dnl comment-start-skip: "\\bdnl\\b\\s *" -dnl End: diff --git a/libguile/continuations.c b/libguile/continuations.c deleted file mode 100644 index f04912c8a..000000000 --- a/libguile/continuations.c +++ /dev/null @@ -1,212 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "stackchk.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "dynwind.h" - -#include "continuations.h" - - -/* {Continuations} - */ - -static char s_cont[] = "continuation"; - - -SCM -scm_make_cont (answer) - SCM * answer; -{ - long j; - SCM cont; - -#ifdef CHEAP_CONTINUATIONS - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont)); - SCM_SETCAR (cont, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE = SCM_EOL; - SCM_BASE (cont) = SCM_BASE (rootcont); - SCM_SEQ (cont) = SCM_SEQ (rootcont); - SCM_ALLOW_INTS; -#else - register SCM_STACKITEM *src, *dst; - -#if 0 - { - SCM winds; - - for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds)) - { - if (SCM_INUMP (SCM_CAR (winds))) - { - scm_relocate_chunk_to_heap (SCM_CAR (winds)); - } - } - } -#endif - - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_FLUSH_REGISTER_WINDOWS; - j = scm_stack_size (SCM_BASE (scm_rootcont)); - SCM_SETJMPBUF (cont, - scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)), - s_cont)); - SCM_SETLENGTH (cont, j, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE (cont) = SCM_EOL; - src = SCM_BASE (cont) = SCM_BASE (scm_rootcont); - SCM_SEQ (cont) = SCM_SEQ (scm_rootcont); - SCM_ALLOW_INTS; -#ifndef SCM_STACK_GROWS_UP - src -= SCM_LENGTH (cont); -#endif /* ndef SCM_STACK_GROWS_UP */ - dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#endif /* def CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (cont) = scm_last_debug_frame; -#endif - return cont; -} - -/* Grow the stack so that there is room */ -/* to copy in the continuation. Then */ -#ifndef CHEAP_CONTINUATIONS - -static void grow_throw SCM_P ((SCM *a)); - -static void -grow_throw (a) - SCM *a; -{ /* retry the throw. */ - SCM growth[100]; - growth[0] = a[0]; - growth[1] = a[1]; - growth[2] = a[2] + 1; - growth[3] = (SCM) a; - scm_dynthrow (growth); -} -#endif /* ndef CHEAP_CONTINUATIONS */ - - -void -scm_dynthrow (a) - SCM *a; -{ - SCM cont = a[0], val = a[1]; -#ifndef CHEAP_CONTINUATIONS - register long j; - register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont); -#ifdef SCM_STACK_GROWS_UP - if (a[2] && (a - ((SCM *) a[3]) < 100)) -#else - if (a[2] && (((SCM *) a[3]) - a < 100)) -#endif - fputs ("grow_throw: check if SCM growth[100]; being optimized out\n", - stderr); - /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", - a[2], (((SCM *)a[3]) - a)); */ -#ifdef SCM_STACK_GROWS_UP - if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a)) - grow_throw (a); -#else - dst -= SCM_LENGTH (cont); - if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a)) - grow_throw (a); -#endif /* def SCM_STACK_GROWS_UP */ - SCM_FLUSH_REGISTER_WINDOWS; - src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#ifdef sparc /* clear out stack up to this stackframe */ - /* maybe this would help, maybe not */ -/* bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) - - (dst - SCM_LENGTH(cont)))) */ -#endif -#endif /* ndef CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (cont); -#endif - SCM_THROW_VALUE(cont) = val; - longjmp (SCM_JMPBUF (cont), 1); -} - - -SCM -scm_call_continuation (cont, val) - SCM cont; - SCM val; -{ - SCM a[3]; - a[0] = cont; - a[1] = val; - a[2] = 0; - if ( (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont)) - || (SCM_BASE (cont) != SCM_BASE (scm_rootcont))) /* base compare not needed */ - scm_wta (cont, "continuation from wrong top level", s_cont); - - scm_dowinds (SCM_DYNENV (cont), - scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont))); - - scm_dynthrow (a); - return SCM_UNSPECIFIED; /* not reached */ -} - - - -void -scm_init_continuations () -{ -#include "continuations.x" -} - diff --git a/libguile/continuations.h b/libguile/continuations.h deleted file mode 100644 index 0bd18296e..000000000 --- a/libguile/continuations.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef CONTINUATIONSH -#define CONTINUATIONSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -typedef struct -{ - SCM throw_value; - jmp_buf jmpbuf; - SCM dynenv; - SCM_STACKITEM *base; - unsigned long seq; - -#ifdef DEBUG_EXTENSIONS - struct scm_debug_frame *dframe; -#endif -} scm_contregs; - -#define SCM_JMPBUF(x) (((scm_contregs *)SCM_CHARS(x))->jmpbuf) -#define SCM_SETJMPBUF SCM_SETCDR -#define SCM_DYNENV(x) (((scm_contregs *)SCM_CHARS(x))->dynenv) -#define SCM_THROW_VALUE(x) (((scm_contregs *)SCM_CHARS(x))->throw_value) -#define SCM_BASE(x) (((scm_contregs *)SCM_CHARS(x))->base) -#define SCM_SEQ(x) (((scm_contregs *)SCM_CHARS(x))->seq) -#define SCM_DFRAME(x) (((scm_contregs *)SCM_CHARS(x))->dframe) - - - -extern SCM scm_make_cont SCM_P ((SCM * answer)); -extern void scm_dynthrow SCM_P ((SCM *a)); -extern SCM scm_call_continuation SCM_P ((SCM cont, SCM val)); -extern void scm_init_continuations SCM_P ((void)); - -#endif /* CONTINUATIONSH */ diff --git a/libguile/dynl-dl.c b/libguile/dynl-dl.c deleted file mode 100644 index 7899b3245..000000000 --- a/libguile/dynl-dl.c +++ /dev/null @@ -1,212 +0,0 @@ -/* dynl-dl.c - dynamic linking for dlopen/dlsym - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include <dlfcn.h> - -#define SHL(obj) ((void*)SCM_CDR(obj)) - -#ifdef RTLD_LAZY /* Solaris 2. */ -# define DLOPEN_MODE RTLD_LAZY -#else -# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ -#endif - -static scm_sizet frshl SCM_P ((SCM ptr)); - -static scm_sizet -frshl (ptr) - SCM ptr; -{ -#if 0 - /* Should freeing a shl close and possibly unmap the object file it */ - /* refers to? */ - if (SHL(ptr)) - dlclose (SHL(ptr)); -#endif - return 0; -} - -static int prinshl SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinshl (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port); - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); - return 1; -} - -int scm_tc16_shl; -static scm_smobfuns shlsmob = { scm_mark0, frshl, prinshl }; - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - SCM z; - void *handle; - - /* if FALSEP(fname) return fname; XXX - ? */ - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - handle = dlopen (SCM_CHARS (fname), DLOPEN_MODE); - if (NULL == handle) - scm_misc_error (s_dynamic_link, (char *)dlerror (), SCM_EOL); - SCM_NEWCELL (z); - SCM_SETCHARS (z, handle); - SCM_SETCAR (z, scm_tc16_shl); - SCM_ALLOW_INTS; - - return z; -} - -static void *get_func SCM_P ((void *handle, char *func, char *subr)); - -static void * -get_func (handle, func, subr) - void *handle; - char *func; - char *subr; -{ - void *fptr; - char *err; - - fptr = dlsym (handle, func); - err = (char *)dlerror (); - if (!fptr) - scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL); - return fptr; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb, shl; -{ - void (*func) SCM_P ((void)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG2, s_dynamic_call); - - SCM_DEFER_INTS; - func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_call); - SCM_ALLOW_INTS; - - (*func) (); - - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG2, s_dynamic_args_call); - - SCM_DEFER_INTS; - func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_args_call); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv(argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM(0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink (shl) - SCM shl; -{ - int status; - - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG1, s_dynamic_unlink); - - SCM_DEFER_INTS; - status = dlclose (SHL(shl)); - SCM_SETCHARS (shl, NULL); - SCM_ALLOW_INTS; - - if (status) - scm_misc_error (s_dynamic_unlink, (char *)dlerror (), SCM_EOL); - return SCM_BOOL_T; -} - -void -scm_init_dynamic_linking () -{ - scm_tc16_shl = scm_newsmob (&shlsmob); -#include "dynl.x" -} diff --git a/libguile/dynl-dld.c b/libguile/dynl-dld.c deleted file mode 100644 index aba8b93ed..000000000 --- a/libguile/dynl-dld.c +++ /dev/null @@ -1,187 +0,0 @@ -/* dynl-dld.c - dynamic linking with dld - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "dld.h" - -static void listundef SCM_P ((void)); - -static void -listundefs () -{ - int i; - char **undefs = dld_list_undefined_sym(); - puts(" undefs:"); - for(i = dld_undefined_sym_count;i--;) { - putc('"', stdout); - fputs(undefs[i], stdout); - puts("\""); - } - free(undefs); -} - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - int status; - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - status = dld_link (SCM_CHARS (fname)); - SCM_ALLOW_INTS; - if (status) - scm_misc_error (s_dynamic_link, dld_strerror (status), SCM_EOL); - return fname; -} - -static void *get_func SCM_P ((char *subr, char *fname)); - -static void * -get_func (subr, fname) - char *subr; - char *fname; -{ - void *func; - - if (!dld_function_executable_p (func)) { - listundefs (); - scm_misc_error (subr, "unresolved symbols remain", SCM_EOL); - } - func = (void *) dld_get_func (func); - if (func == 0) - scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL); - return func; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb; - SCM shl; -{ - void (*func)() = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - - SCM_DEFER_INTS; - func = get_func (s_dynamic_call, SCM_CHARS (symb)); - SCM_ALLOW_INST; - (*func) (); - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - - SCM_DEFER_INTS; - func = get_func (SCM_CHARS (symb), s_dynamic_args_call); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv(argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM(0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink(fname) - SCM fname; -{ - int status; - - fname = scm_coerce_rostring (fname, s_dynamic_unlink, SCM_ARG1); - - SCM_DEFER_INTS; - status = dld_unlink_by_file (SCM_CHARS (fname), 1); - SCM_ALLOW_INTS; - - if (status) - scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL); - return SCM_BOOL_T; -} - -void -scm_init_dynamic_linking () -{ -#ifndef RTL - if (!execpath) - execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs))); - if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) { - dld_perror("DLD"); - return; - } -#endif - -#include "dynl.x" - -#ifdef DLD_DYNCM /* XXX - what's this? */ - add_feature("dld:dyncm"); -#endif -} diff --git a/libguile/dynl-shl.c b/libguile/dynl-shl.c deleted file mode 100644 index b8e474484..000000000 --- a/libguile/dynl-shl.c +++ /dev/null @@ -1,172 +0,0 @@ -/* dynl-shl.c - dynamic linking with shl_load (HP-UX) - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "dl.h" - -#define SHL(obj) ((shl_t*)SCM_CDR(obj)) - -static int printshl SCM_P ((SCM exp, SCM port, scm_printstate *pstate)); - -static int -prinshl (exp, port, pstate) - SCM exp; - SCM port; - scm_printstate *pstate; -{ - scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port); - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); - return 1; -} - -int scm_tc16_shl; -static scm_smobfuns shlsmob = { scm_mark0, scm_free0, prinshl }; - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - SCM z; - shl_t shl; - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - shl = shl_load (SCM_CHARS (fname), BIND_DEFERRED , 0L); - if (NULL==shl) - scm_misc_error (s_dynamic_link, "dynamic linking failed", SCM_EOL); - SCM_NEWCELL (z); - SCM_SETCHARS (z, shl); - SCM_SETCAR (z, scm_tc16_shl); - SCM_ALLOW_INTS; - - return z; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb, shl; -{ - void (*func)() = 0; - int i; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, SCM_ARG2, - s_dynamic_call); - - SCM_DEFER_INTS; - if (shl_findsym (&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func)) - scm_misc_error (s_dynamic_call, "undefined function", - scm_cons (symb, SCM_EOL)); - SCM_ALLOW_INTS; - - (*func) (); - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR(shl) == scm_tc16_shl, shl, SCM_ARG2, - s_dynamic_args_call); - - SCM_DEFER_INTS; - if (shl_findsym(&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func)) - scm_misc_error (s_dynamic_call, "undefined function: %s", - scm_cons (symb, SCM_EOL)); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv (argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM (0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink (shl) - SCM shl; -{ - int status; - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG1, s_dynamic_unlink); - - SCM_DEFER_INTS; - status = shl_unload (SHL (shl)); - SCM_ALLOW_INTS; - if (!status) - return SCM_BOOL_T; - return SCM_BOOL_F; -} - -void -scm_init_dynamic_linking () -{ - scm_tc16_shl = scm_newsmob (&shlsmob); -#include "dynl.x" -} diff --git a/libguile/dynl-vms.c b/libguile/dynl-vms.c deleted file mode 100644 index 322839cbc..000000000 --- a/libguile/dynl-vms.c +++ /dev/null @@ -1,106 +0,0 @@ -/* dynl-vms.c - dynamic linking for VMS, not yet ported - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - (Not yet) modified for libguile by Marius Vollmer */ - -/* We should try to implement dynamic-link/dynamic-call for VMS, - too. */ - -#include "_scm.h" - -/* This permits dynamic linking. For example, the procedure of 0 arguments - from a file could be the initialization procedure. - (vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO") - The first argument specifies the directory where the file specified - by the second argument resides. The current directory would be - "SYS$DISK:[].EXE". - The second argument cannot contain any punctuation. - The third argument probably needs to be uppercased to mimic the VMS linker. - */ - -# include <descrip.h> -# include <ssdef.h> -# include <rmsdef.h> - -struct dsc$descriptor *descriptorize(x, buff) - struct dsc$descriptor *x; - SCM buff; -{(*x).dsc$w_length = LENGTH(buff); - (*x).dsc$a_pointer = CHARS(buff); - (*x).dsc$b_class = DSC$K_CLASS_S; - (*x).dsc$b_dtype = DSC$K_DTYPE_T; - return(x);} - -static char s_dynl[] = "vms:dynamic-link-call"; -SCM dynl(dir, symbol, fname) - SCM dir, symbol, fname; -{ - struct dsc$descriptor fnamed, symbold, dird; - void (*fcn)(); - long retval; - ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl); - ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl); - ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl); - descriptorize(&fnamed, fname); - descriptorize(&symbold, symbol); - DEFER_INTS; - retval = lib$find_image_symbol(&fnamed, &symbold, &fcn, - IMP(dir) ? 0 : descriptorize(&dird, dir)); - if (SS$_NORMAL != retval) { - /* wta(MAKINUM(retval), "vms error", s_dynl); */ - ALLOW_INTS; - return BOOL_F; - } - ALLOW_INTS; -/* *loc_loadpath = dir; */ - (*fcn)(); -/* *loc_loadpath = oloadpath; */ - return BOOL_T; -} - -void init_dynl() -{ - make_subr(s_dynl, tc7_subr_3, dynl); -} diff --git a/libguile/dynl.c b/libguile/dynl.c deleted file mode 100644 index 800de3d7b..000000000 --- a/libguile/dynl.c +++ /dev/null @@ -1,147 +0,0 @@ -/* dynl.c - dynamic linking - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" - -/* Converting a list of SCM strings into a argv-style array. You must - have ints disabled for the whole lifetime of the created argv (from - before MAKE_ARGV_FROM_STRINGLIST until after - MUST_FREE_ARGV). Atleast this is was the documentation for - MAKARGVFROMSTRS says, it isn't really used that way. - - This code probably belongs into strings.c */ - -static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp, - char *subr, int argn)); - -static char ** -scm_make_argv_from_stringlist (args, argcp, subr, argn) - SCM args; - int *argcp; - char *subr; - int argn; -{ - char **argv; - int argc, i; - - argc = scm_ilength(args); - argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr); - for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) { - size_t len; - char *dst, *src; - SCM str = SCM_CAR (args); - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, argn, subr); - len = 1 + SCM_ROLENGTH (str); - dst = (char *) scm_must_malloc ((long)len, subr); - src = SCM_ROCHARS (str); - while (len--) - dst[len] = src[len]; - argv[i] = dst; - } - - if (argcp) - *argcp = argc; - argv[argc] = 0; - return argv; -} - -static void scm_must_free_argv SCM_P ((char **argv)); - -static void -scm_must_free_argv(argv) - char **argv; -{ - char **av = argv; - while(!(*av)) - free(*(av++)); - free(argv); -} - -/* Coerce an arbitrary readonly-string into a zero-terminated string. - */ - -static SCM scm_coerce_rostring SCM_P ((SCM rostr, char *subr, int argn)); - -static SCM -scm_coerce_rostring (rostr, subr, argn) - SCM rostr; - char *subr; - int argn; -{ - SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr); - if (SCM_SUBSTRP (rostr)) - rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0); - return rostr; -} - -/* Dispatch to the system dependent files - */ - -#ifdef DYNAMIC_LINKING -#ifdef HAVE_LIBDL -#include "dynl-dl.c" -#else -#ifdef HAVE_SHL_LOAD -#include "dynl-shl.c" -#else -#ifdef HAVE_DLD -#include "dynl-dld.c" -#else /* no dynamic linking available */ -void -scm_init_dynamic_linking () -{ -} -#endif -#endif -#endif -#else /* dynamic linking disabled */ -void -scm_init_dynamic_linking () -{ -} -#endif diff --git a/libguile/dynl.h b/libguile/dynl.h deleted file mode 100644 index 723d2e950..000000000 --- a/libguile/dynl.h +++ /dev/null @@ -1,57 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#ifndef LIBGUILE_DYNL_H -#define LIBGUILE_DYNL_H - -#include "libguile/__scm.h" - - - -SCM scm_dynamic_link SCM_P ((SCM fname)); -SCM scm_dynamic_call SCM_P ((SCM symb, SCM shl)); -SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM shl, SCM args)); -SCM scm_dynamic_unlink SCM_P ((SCM shl)); - -void scm_init_dynamic_linking SCM_P ((void)); - -#endif /* LIBGUILE_DYNL_H */ diff --git a/libguile/dynwind.c b/libguile/dynwind.c deleted file mode 100644 index 4a9424b0f..000000000 --- a/libguile/dynwind.c +++ /dev/null @@ -1,139 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eval.h" -#include "alist.h" - -#include "dynwind.h" - - -/* {Dynamic wind} - */ - - - -SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind); - -SCM -scm_dynamic_wind (thunk1, thunk2, thunk3) - SCM thunk1; - SCM thunk2; - SCM thunk3; -{ - SCM ans; - scm_apply (thunk1, SCM_EOL, SCM_EOL); - scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds); - ans = scm_apply (thunk2, SCM_EOL, SCM_EOL); - scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_apply (thunk3, SCM_EOL, SCM_EOL); - return ans; -} - - -void -scm_dowinds (to, delta) - SCM to; - long delta; -{ - tail: - if (scm_dynwinds == to); - else if (0 > delta) - { - SCM wind_elt; - SCM wind_key; - - scm_dowinds (SCM_CDR (to), 1 + delta); - wind_elt = SCM_CAR (to); -#if 0 - if (SCM_INUMP (wind_elt)) - { - scm_cross_dynwind_binding_scope (wind_elt, 0); - } - else -#endif - { - wind_key = SCM_CAR (wind_elt); - if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key)) - && (wind_key != SCM_BOOL_F) - && (wind_key != SCM_BOOL_T)) - scm_apply (wind_key, SCM_EOL, SCM_EOL); - } - scm_dynwinds = to; - } - else - { - SCM from; - SCM wind_elt; - SCM wind_key; - - from = SCM_CDR (SCM_CAR (scm_dynwinds)); - wind_elt = SCM_CAR (scm_dynwinds); - scm_dynwinds = SCM_CDR (scm_dynwinds); -#if 0 - if (SCM_INUMP (wind_elt)) - { - scm_cross_dynwind_binding_scope (wind_elt, 0); - } - else -#endif - { - wind_key = SCM_CAR (wind_elt); - if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key)) - && (wind_key != SCM_BOOL_F) - && (wind_key != SCM_BOOL_T)) - scm_apply (from, SCM_EOL, SCM_EOL); - } - delta--; - goto tail; /* scm_dowinds(to, delta-1); */ - } -} - - - -void -scm_init_dynwind () -{ -#include "dynwind.x" -} - diff --git a/libguile/dynwind.h b/libguile/dynwind.h deleted file mode 100644 index 7352751c0..000000000 --- a/libguile/dynwind.h +++ /dev/null @@ -1,54 +0,0 @@ -/* classes: h_files */ - -#ifndef DYNWINDH -#define DYNWINDH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_dynamic_wind SCM_P ((SCM thunk1, SCM thunk2, SCM thunk3)); -extern void scm_dowinds SCM_P ((SCM to, long delta)); -extern void scm_init_dynwind SCM_P ((void)); - -#endif /* DYNWINDH */ diff --git a/libguile/eq.c b/libguile/eq.c deleted file mode 100644 index 5bc88fe75..000000000 --- a/libguile/eq.c +++ /dev/null @@ -1,152 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "ramap.h" -#include "stackchk.h" -#include "strorder.h" -#include "smob.h" -#include "unif.h" - -#include "eq.h" - -SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p); - -SCM -scm_eq_p (x, y) - SCM x; - SCM y; -{ - return ((x==y) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p); - -SCM -scm_eqv_p (x, y) - SCM x; - SCM y; -{ - if (x==y) return SCM_BOOL_T; - if SCM_IMP(x) return SCM_BOOL_F; - if SCM_IMP(y) return SCM_BOOL_F; - /* this ensures that types and scm_length are the same. */ - if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F; - if SCM_NUMP(x) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif -#ifdef SCM_FLOATS - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F; -#endif - return SCM_BOOL_T; - } - return SCM_BOOL_F; -} - - -SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p); - -SCM -scm_equal_p (x, y) - SCM x; - SCM y; -{ - SCM_CHECK_STACK; - tailrecurse: SCM_ASYNC_TICK; - if (x==y) return SCM_BOOL_T; - if (SCM_IMP(x)) return SCM_BOOL_F; - if (SCM_IMP(y)) return SCM_BOOL_F; - if (SCM_CONSP(x) && SCM_CONSP(y)) { - if SCM_FALSEP(scm_equal_p(SCM_CAR(x), SCM_CAR(y))) return SCM_BOOL_F; - x = SCM_CDR(x); - y = SCM_CDR(y); - goto tailrecurse; - } - /* this ensures that types and scm_length are the same. */ - if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F; - switch (SCM_TYP7(x)) { - default: return SCM_BOOL_F; - case scm_tc7_substring: - case scm_tc7_mb_substring: - case scm_tc7_mb_string: - case scm_tc7_string: return scm_string_equal_p(x, y); - case scm_tc7_vector: - case scm_tc7_wvect: - return scm_vector_equal_p(x, y); - case scm_tc7_smob: { - int i = SCM_SMOBNUM(x); - if (!(i < scm_numsmob)) return SCM_BOOL_F; - if (scm_smobs[i].equalp) - return (scm_smobs[i].equalp)(x, y); - else - return SCM_BOOL_F; - } - case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect: - case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_byvect: - if ( scm_tc16_array - && scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp) - return scm_array_equal_p(x, y); - } - return SCM_BOOL_F; -} - - - - - - -void -scm_init_eq () -{ -#include "eq.x" -} - diff --git a/libguile/eq.h b/libguile/eq.h deleted file mode 100644 index c9deb5007..000000000 --- a/libguile/eq.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef EQH -#define EQH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_eqv_p SCM_P ((SCM x, SCM y)); -extern SCM scm_equal_p SCM_P ((SCM x, SCM y)); -extern void scm_init_eq SCM_P ((void)); - -#endif /* EQH */ diff --git a/libguile/error.c b/libguile/error.c deleted file mode 100644 index 68f24a985..000000000 --- a/libguile/error.c +++ /dev/null @@ -1,328 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "pairs.h" -#include "genio.h" -#include "throw.h" - -#include "error.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - -/* {Errors and Exceptional Conditions} - */ - - -/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and - * when the interpreter is not running at all. - */ -int scm_ints_disabled = 1; - -extern int errno; - -static void err_head SCM_P ((char *str)); - -static void -err_head (str) - char *str; -{ - int oerrno = errno; - if (SCM_NIMP (scm_cur_outp)) - scm_fflush (scm_cur_outp); - scm_gen_putc ('\n', scm_cur_errp); -#if 0 - if (SCM_BOOL_F != *scm_loc_loadpath) - { - scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1); - scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp); - scm_intprint ((long) scm_linum, 10, scm_cur_errp); - scm_gen_puts (scm_regular_string, ": ", scm_cur_errp); - } -#endif - scm_fflush (scm_cur_errp); - errno = oerrno; - if (scm_cur_errp == scm_def_errp) - { - if (errno > 0) - perror (str); - fflush (stderr); - return; - } -} - - -SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno); -SCM -scm_errno (arg) - SCM arg; -{ - int old = errno; - if (!SCM_UNBNDP (arg)) - { - if (SCM_FALSEP (arg)) - errno = 0; - else - errno = SCM_INUM (arg); - } - return SCM_MAKINUM (old); -} - -SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror); -SCM -scm_perror (arg) - SCM arg; -{ - SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror); - err_head (SCM_CHARS (arg)); - return SCM_UNSPECIFIED; -} - -void (*scm_error_callback) () = 0; - -/* all errors thrown from C should pass through here. */ -void -scm_error (key, subr, message, args, rest) - SCM key; - char *subr; - char *message; - SCM args; - SCM rest; -{ - SCM arg_list; - if (scm_error_callback) - (*scm_error_callback) (key, subr, message, args, rest); - - arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest, - SCM_UNDEFINED); - scm_ithrow (key, arg_list, 1); - - /* No return, but just in case: */ - - write (2, "unhandled system error", sizeof ("unhandled system error") - 1); - exit (1); -} - -SCM_SYMBOL (scm_system_error_key, "system-error"); -void -scm_syserror (subr) - char *subr; -{ - scm_error (scm_system_error_key, - subr, - "%s", - scm_listify (scm_makfrom0str (strerror (errno)), - SCM_UNDEFINED), - scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED)); -} - -void -scm_syserror_msg (subr, message, args) - char *subr; - char *message; - SCM args; -{ - scm_error (scm_system_error_key, - subr, - message, - args, - scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED)); -} - -void -scm_sysmissing (subr) - char *subr; -{ -#ifdef ENOSYS - scm_error (scm_system_error_key, - subr, - "%s", - scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED), - scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED)); -#else - scm_error (scm_system_error_key, - subr, - "Missing function", - SCM_BOOL_F, - scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED)); -#endif -} - -SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow"); -void -scm_num_overflow (subr) - char *subr; -{ - scm_error (scm_num_overflow_key, - subr, - "Numerical overflow", - SCM_BOOL_F, - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_out_of_range_key, "out-of-range"); -void -scm_out_of_range (subr, bad_value) - char *subr; - SCM bad_value; -{ - scm_error (scm_out_of_range_key, - subr, - "Argument out of range: %S", - scm_listify (bad_value, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args"); -void -scm_wrong_num_args (proc) - SCM proc; -{ - scm_error (scm_args_number_key, - NULL, - "Wrong number of arguments to %s", - scm_listify (proc, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg"); -void -scm_wrong_type_arg (subr, pos, bad_value) - char *subr; - int pos; - SCM bad_value; -{ - scm_error (scm_arg_type_key, - subr, - (pos == 0) ? "Wrong type argument: %S" - : "Wrong type argument in position %s: %S", - (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED) - : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error"); -void -scm_memory_error (subr) - char *subr; -{ - scm_error (scm_memory_alloc_key, - subr, - "Memory allocation error", - SCM_BOOL_F, - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_misc_error_key, "misc-error"); -void -scm_misc_error (subr, message, args) - char *subr; - char *message; - SCM args; -{ - scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F); -} - -/* implements the SCM_ASSERT interface. */ -SCM -scm_wta (arg, pos, s_subr) - SCM arg; - char *pos; - char *s_subr; -{ - if (!s_subr || !*s_subr) - s_subr = NULL; - if ((~0x1fL) & (long) pos) - { - /* error string supplied. */ - scm_misc_error (s_subr, pos, SCM_BOOL_F); - } - else - { - /* numerical error code. */ - int error = (long) pos; - - switch (error) - { - case SCM_ARGn: - scm_wrong_type_arg (s_subr, 0, arg); - case SCM_ARG1: - scm_wrong_type_arg (s_subr, 1, arg); - case SCM_ARG2: - scm_wrong_type_arg (s_subr, 2, arg); - case SCM_ARG3: - scm_wrong_type_arg (s_subr, 3, arg); - case SCM_ARG4: - scm_wrong_type_arg (s_subr, 4, arg); - case SCM_ARG5: - scm_wrong_type_arg (s_subr, 5, arg); - case SCM_WNA: - scm_wrong_num_args (arg); - case SCM_OUTOFRANGE: - scm_out_of_range (s_subr, arg); - case SCM_NALLOC: - scm_memory_error (s_subr); - default: - /* this shouldn't happen. */ - scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F); - } - } - return SCM_UNSPECIFIED; -} - -/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr) - was equivalent to scm_wta (arg, pos, s_subr) */ - -void -scm_init_error () -{ -#include "error.x" -} - diff --git a/libguile/error.h b/libguile/error.h deleted file mode 100644 index 0ce16289a..000000000 --- a/libguile/error.h +++ /dev/null @@ -1,84 +0,0 @@ -/* classes: h_files */ - -#ifndef ERRORH -#define ERRORH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern int scm_ints_disabled; - - - -/* GCC can be told that a function doesn't return; this helps it do - better error checking (for uninitialized variable use, for - example), and some optimization. */ -#ifdef __GNUC__ -#define SCM_NORETURN __attribute__ ((noreturn)) -#else -#define SCM_NORETURN -#endif - - -extern SCM scm_errno SCM_P ((SCM arg)); -extern SCM scm_perror SCM_P ((SCM arg)); -extern void scm_error SCM_P ((SCM key, char *subr, char *message, - SCM args, SCM rest)) SCM_NORETURN; -extern void (*scm_error_callback) SCM_P ((SCM key, char *subr, - char *message, SCM args, SCM rest)); -extern void scm_syserror SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args)) - SCM_NORETURN; -extern void scm_sysmissing SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_num_overflow SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value)) SCM_NORETURN; -extern void scm_wrong_num_args SCM_P ((SCM proc)) SCM_NORETURN; -extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value)) - SCM_NORETURN; -extern void scm_memory_error SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_misc_error SCM_P ((char *subr, char *message, SCM args)) - SCM_NORETURN; -extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr)); -extern void scm_init_error SCM_P ((void)); - -#endif /* ERRORH */ diff --git a/libguile/eval.h b/libguile/eval.h deleted file mode 100644 index f83eb1560..000000000 --- a/libguile/eval.h +++ /dev/null @@ -1,170 +0,0 @@ -/* classes: h_files */ - -#ifndef EVALH -#define EVALH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -/* {Ilocs} - * - * Ilocs are relative pointers into local environment structures. - * - */ -#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc) -#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) -#define SCM_IDINC (0x00100000L) -#define SCM_ICDR (0x00080000L) -#define SCM_IFRINC (0x00000100L) -#define SCM_IDSTMSK (-SCM_IDINC) -#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) -#define SCM_IDIST(n) (((unsigned long)(n))>>20) -#define SCM_ICDRP(n) (SCM_ICDR & (n)) - - - - -/* {Evaluator} - * - * For an explanation of symbols containing "EVAL", see beginning of eval.c. - */ -#ifdef DEBUG_EXTENSIONS -#define XEVAL(x, env) (SCM_IMP(x) \ - ? (x) \ - : (*scm_ceval_ptr) ((x), (env))) -#else -#define XEVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env))) -#endif /* DEBUG_EXTENSIONS */ - -#define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env)) - - - -#define SCM_EXTEND_ENV scm_acons - - -extern SCM scm_i_dot; -extern SCM scm_i_quote; -extern SCM scm_i_quasiquote; -extern SCM scm_i_lambda; -extern SCM scm_i_let; -extern SCM scm_i_arrow; -extern SCM scm_i_else; -extern SCM scm_i_unquote; -extern SCM scm_i_uq_splicing; -extern SCM scm_i_apply; - - -/* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a pair with a - * tag of 1. This is called a "gloc". - */ - -#define SCM_GLOC_SYM(x) (SCM_CAR((x)-1L)) -#define SCM_GLOC_VAL(x) (SCM_CDR((x)-1L)) -#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC((x)-1L)) - - - -extern SCM * scm_ilookup SCM_P ((SCM iloc, SCM env)); -extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv)); -extern SCM scm_unmemocar SCM_P ((SCM form, SCM env)); -extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env)); -extern SCM scm_eval_car SCM_P ((SCM pair, SCM env)); -extern SCM scm_eval_args SCM_P ((SCM i, SCM env)); -extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM *lloc)); -extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_begin SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_if SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_set SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_vref SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_vset SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_and SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_or SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_case SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_cond SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_lambda SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_letstar SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_do SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_quasiquote SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_delay SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_define SCM_P ((SCM x, SCM env)); -extern SCM scm_m_letrec SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_let SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_apply SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_cont SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_undefine SCM_P ((SCM x, SCM env)); -extern int scm_badargsp SCM_P ((SCM formals, SCM args)); -extern SCM scm_ceval SCM_P ((SCM x, SCM env)); -extern SCM scm_deval SCM_P ((SCM x, SCM env)); -extern SCM scm_procedure_documentation SCM_P ((SCM proc)); -extern SCM scm_nconc2last SCM_P ((SCM lst)); -extern SCM scm_apply SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_dapply SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM SCM_APPLY SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_map SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_for_each SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_closure SCM_P ((SCM code, SCM env)); -extern SCM scm_makprom SCM_P ((SCM code)); -extern SCM scm_makacro SCM_P ((SCM code)); -extern SCM scm_makmacro SCM_P ((SCM code)); -extern SCM scm_makmmacro SCM_P ((SCM code)); -extern SCM scm_force SCM_P ((SCM x)); -extern SCM scm_promise_p SCM_P ((SCM x)); -extern SCM scm_copy_tree SCM_P ((SCM obj)); -extern SCM scm_eval_3 SCM_P ((SCM obj, int copyp, SCM env)); -extern SCM scm_top_level_env SCM_P ((SCM thunk)); -extern SCM scm_eval2 SCM_P ((SCM obj, SCM env_thunk)); -extern SCM scm_eval SCM_P ((SCM obj)); -extern SCM scm_eval_x SCM_P ((SCM obj)); -extern SCM scm_macro_eval_x SCM_P ((SCM exp, SCM env)); -extern SCM scm_definedp SCM_P ((SCM sym)); -extern SCM scm_make_synt SCM_P ((char *name, - SCM (*macroizer) (SCM), - SCM (*fcn) ())); -extern void scm_init_eval SCM_P ((void)); - -#endif /* EVALH */ diff --git a/libguile/extchrs.c b/libguile/extchrs.c deleted file mode 100644 index 6b063da8a..000000000 --- a/libguile/extchrs.c +++ /dev/null @@ -1,134 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "extchrs.h" - - - -#ifdef SCM_FAKE_EXT_CHARS - - -int -xmblen (str, size) - const char * str; - size_t size; -{ - if (!str) - return 0; - - if (*(unsigned char *)str > 127) - return ((size < 4) - ? -1 - : 4); - else if (!*str) - return 0; - else - return 1; -} - - -int -xwctomb (_str, c) - char * _str; - int c; -{ - unsigned char * str; - str = (unsigned char *)_str; - if (!str) - return 0; - - if (!c) - { - *str = 0; - return 0; - } - - - if (c < 127) - { - *str = c; - return 1; - } - - str[0] = 255; - str[1] = 0x80 | ((c >> 10) & 0x3f); - str[2] = 0x80 | ((c >> 4) & 0x3f); - str[3] = 0x80 | (c & 0xf); - return 4; -} - - -int -xmbtowc (result, _str, size) - xwchar_t * result; - const unsigned char * _str; - size_t size; -{ - const unsigned char * str; - str = (const unsigned char *)_str; - if (!str) - return 0; - - if ((size == 0) || !*str) - { - *result = 0; - return 0; - } - - if (*str < 128) - { - *result = *str; - return 1; - } - - if ( (*str != 255) - || (size < 4)) - return -1; - - *result = ( ((str[1] & 0x3f) << 10) - | ((str[2] & 0x3f) << 4) - | (str[3] & 0xf)); - return 4; -} - -#endif /* SCM_FAKE_EXT_CHARS */ - diff --git a/libguile/extchrs.h b/libguile/extchrs.h deleted file mode 100644 index 3f1f02276..000000000 --- a/libguile/extchrs.h +++ /dev/null @@ -1,74 +0,0 @@ -/* classes: h_files */ - -#ifndef EXTCHRSH -#define EXTCHRSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdlib.h> - -#include "libguile/__scm.h" - -#define SCM_FAKE_EXT_CHARS 1 - -#if !defined(SCM_FAKE_EXT_CHARS) - -#define xmblen mblen -#define xwctomb wctomb -#define xmbtowc mbtowc -#define XMB_CUR_MAX MB_CUR_MAX -typedef wchar_t xwchar_t; - -#else - -typedef unsigned short xwchar_t; -#define XMB_CUR_MAX 4 - -#endif - - - -extern int xmblen SCM_P ((const char * str, size_t size)); -extern int xwctomb SCM_P ((char * _str, int c)); -extern int xmbtowc SCM_P ((xwchar_t * result, const unsigned char * _str, size_t size)); - -#endif /* EXTCHRSH */ diff --git a/libguile/feature.c b/libguile/feature.c deleted file mode 100644 index 9aaee678c..000000000 --- a/libguile/feature.c +++ /dev/null @@ -1,121 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "feature.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - -static SCM *scm_loc_features; - -void -scm_add_feature(str) - char* str; -{ - *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))), - *scm_loc_features); -} - - - -SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments); - -SCM -scm_program_arguments () -{ - return scm_progargs; -} - -/* Set the value returned by program-arguments, given ARGC and ARGV. - - If FIRST is non-zero, make it the first element; we do this in - situations where other code (like getopt) has parsed out a few - arguments, but we still want the script name to be the first - element. */ -void -scm_set_program_arguments (argc, argv, first) - int argc; - char **argv; - char *first; -{ - scm_progargs = scm_makfromstrs (argc, argv); - if (first) - scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs); -} - - - - -void -scm_init_feature() -{ - scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL)); -#ifdef RECKLESS - scm_add_feature("reckless"); -#endif -#ifndef _Windows - scm_add_feature("system"); -#endif -#ifdef vms - scm_add_feature(s_ed); -#endif -#ifdef SICP - scm_add_feature("sicp"); -#endif -#ifndef GO32 - scm_add_feature("char-ready?"); -#endif -#ifndef CHEAP_CONTINUATIONS - scm_add_feature ("full-continuation"); -#endif -#ifdef USE_THREADS - scm_add_feature ("threads"); -#endif - - scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); -#include "feature.x" -} diff --git a/libguile/feature.h b/libguile/feature.h deleted file mode 100644 index 712aff8a0..000000000 --- a/libguile/feature.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef FEATUREH -#define FEATUREH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern void scm_add_feature SCM_P((char* str)); -extern SCM scm_program_arguments SCM_P((void)); -extern void scm_set_program_arguments SCM_P ((int argc, char **argv, - char *first)); -extern void scm_init_feature SCM_P((void)); - -#endif /* FEATUREH */ diff --git a/libguile/filesys.c b/libguile/filesys.c deleted file mode 100644 index 38f0b7768..000000000 --- a/libguile/filesys.c +++ /dev/null @@ -1,1311 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" -#include "feature.h" - -#include "filesys.h" - -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef LIBC_H_WITH_UNISTD_H -#include <libc.h> -#endif - -#ifdef HAVE_SYS_SELECT_H -#include <sys/select.h> -#endif - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -#include <pwd.h> - - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ - -#if HAVE_DIRENT_H -# include <dirent.h> -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include <sys/ndir.h> -# endif -# if HAVE_SYS_DIR_H -# include <sys/dir.h> -# endif -# if HAVE_NDIR_H -# include <ndir.h> -# endif -#endif - - - -#ifdef O_CREAT -SCM_CONST_LONG (scm_O_CREAT, "O_CREAT", O_CREAT); -#endif - -#ifdef O_EXCL -SCM_CONST_LONG (scm_O_EXCL, "O_EXCL", O_EXCL); -#endif - -#ifdef O_NOCTTY -SCM_CONST_LONG (scm_O_NOCTTY, "O_NOCTTY", O_NOCTTY); -#endif - -#ifdef O_TRUNC -SCM_CONST_LONG (scm_O_TRUNC, "O_TRUNC", O_TRUNC); -#endif - -#ifdef O_APPEND -SCM_CONST_LONG (scm_O_APPEND, "O_APPEND", O_APPEND); -#endif - -#ifdef O_NONBLOCK -SCM_CONST_LONG (scm_O_NONBLOCK, "O_NONBLOCK", O_NONBLOCK); -#endif - -#ifdef O_NDELAY -SCM_CONST_LONG (scm_O_NDELAY, "O_NDELAY", O_NDELAY); -#endif - -#ifdef O_SYNC -SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC); -#endif - - - - - -/* {Permissions} - */ - -SCM_PROC (s_sys_chown, "chown", 3, 0, 0, scm_sys_chown); - -SCM -scm_sys_chown (path, owner, group) - SCM path; - SCM owner; - SCM group; -{ - int val; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown); - SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown); - SCM_SYSCALL (val = chown (SCM_ROCHARS (path), - SCM_INUM (owner), SCM_INUM (group))); - if (val != 0) - scm_syserror (s_sys_chown); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_chmod, "chmod", 2, 0, 0, scm_sys_chmod); - -SCM -scm_sys_chmod (port_or_path, mode) - SCM port_or_path; - SCM mode; -{ - int rv; - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_chmod); - SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod); - if (SCM_STRINGP (port_or_path)) - SCM_SYSCALL (rv = chmod (SCM_CHARS (port_or_path), SCM_INUM (mode))); - else - { - SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod); - rv = fileno ((FILE *)SCM_STREAM (port_or_path)); - if (rv != -1) - SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode))); - } - if (rv != 0) - scm_syserror (s_sys_chmod); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask); - -SCM -scm_umask (mode) - SCM mode; -{ - mode_t mask; - if (SCM_UNBNDP (mode)) - { - mask = umask (0); - umask (mask); - } - else - { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG1, s_umask); - mask = umask (SCM_INUM (mode)); - } - return SCM_MAKINUM (mask); -} - - -/* {File Descriptors} - */ -long scm_tc16_fd; - - -static int scm_fd_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); - -static int -scm_fd_print (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<fd ", port); - scm_intprint (SCM_CDR (sexp), 10, port); - scm_gen_puts (scm_regular_string, ">", port); - return 1; -} - - -static scm_sizet scm_fd_free SCM_P ((SCM p)); - -static scm_sizet -scm_fd_free (p) - SCM p; -{ - SCM flags; - - flags = SCM_FD_FLAGS (p); - if ((scm_close_fd_on_gc & flags) && (scm_fd_is_open & flags)) - { - SCM_SYSCALL( close (SCM_FD (p)) ); - } - return 0; -} - -static scm_smobfuns fd_smob = {scm_mark0, scm_fd_free, scm_fd_print, 0}; - - -SCM -scm_intern_fd (fd, flags) - int fd; - int flags; -{ - SCM it; - SCM_NEWCELL (it); - SCM_REDEFER_INTS; - SCM_SETCAR (it, (scm_tc16_fd | (flags << 16))); - SCM_SETCDR (it, (SCM)fd); - SCM_REALLOW_INTS; - return it; -} - - - -SCM_PROC (s_sys_open, "open", 3, 0, 0, scm_sys_open); - -SCM -scm_sys_open (path, flags, mode) - SCM path; - SCM flags; - SCM mode; -{ - int fd; - SCM sfd; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_open); - SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_sys_open); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_sys_open); - - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - - SCM_DEFER_INTS; - SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) ); - if (fd == -1) - scm_syserror (s_sys_open); - sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc); - SCM_ALLOW_INTS; - - return scm_return_first (sfd, path); -} - - -SCM_PROC (s_sys_create, "create", 2, 0, 0, scm_sys_create); - -SCM -scm_sys_create (path, mode) - SCM path; - SCM mode; -{ - int fd; - SCM sfd; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_create); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_create); - - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - - SCM_DEFER_INTS; - SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) ); - if (fd == -1) - scm_syserror (s_sys_create); - sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc); - SCM_ALLOW_INTS; - - return scm_return_first (sfd, path); -} - - -SCM_PROC (s_sys_close, "close", 1, 0, 0, scm_sys_close); - -SCM -scm_sys_close (sfd) - SCM sfd; -{ - int fd; - int got; - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_close); - fd = SCM_FD (sfd); - - SCM_DEFER_INTS; - got = close (fd); - SCM_SETCAR (sfd, scm_tc16_fd); - SCM_ALLOW_INTS; - if (got == -1) - scm_syserror (s_sys_close); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_write_fd, "write-fd", 2, 0, 0, scm_sys_write_fd); - -SCM -scm_sys_write_fd (sfd, buf) - SCM sfd; - SCM buf; -{ - SCM answer; - int fd; - size_t written; - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_write_fd); - SCM_ASSERT (SCM_NIMP (buf) && SCM_ROSTRINGP (buf), buf, SCM_ARG2, s_sys_write_fd); - fd = SCM_FD (sfd); - SCM_DEFER_INTS; - written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf)); - if (written == -1) - scm_syserror (s_sys_write_fd); - answer = scm_long2num (written); - SCM_ALLOW_INTS; - return scm_return_first (answer, buf); -} - - -SCM_PROC (s_sys_read_fd, "read-fd", 2, 2, 0, scm_sys_read_fd); - -SCM -scm_sys_read_fd (sfd, buf, offset, length) - SCM sfd; - SCM buf; - SCM offset; - SCM length; -{ - SCM answer; - int fd; - char * bytes; - int off; - int len; - size_t got; - - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_read_fd); - fd = SCM_FD (sfd); - - SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_sys_read_fd); - bytes = SCM_CHARS (buf); - - if (SCM_UNBNDP (offset)) - off = 0; - else - { - SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG3, s_sys_read_fd); - off = SCM_INUM (offset); - } - - if (SCM_UNBNDP (length)) - len = SCM_LENGTH (buf); - else - { - SCM_ASSERT (SCM_INUMP (length), length, SCM_ARG3, s_sys_read_fd); - len = SCM_INUM (length); - } - - SCM_DEFER_INTS; - got = read (fd, bytes + off, len); - if (got == -1) - scm_syserror (s_sys_read_fd); - answer = scm_long2num (got); - SCM_ALLOW_INTS; - return scm_return_first (answer, buf); -} - -SCM_PROC (s_sys_lseek, "lseek", 2, 1, 0, scm_sys_lseek); - -SCM -scm_sys_lseek (sfd, offset, whence) - SCM sfd; - SCM offset; - SCM whence; -{ - SCM answer; - int fd; - long off; - int wh; - long got; - - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_lseek); - fd = SCM_FD (sfd); - - off = scm_num2long (offset, (char *)SCM_ARG2, s_sys_lseek); - if (SCM_UNBNDP (whence)) - wh = SEEK_SET; - else - { - SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_sys_lseek); - wh = SCM_INUM (whence); - } - - SCM_DEFER_INTS; - SCM_SYSCALL (got = lseek (fd, off, wh)); - if (got == -1) - scm_syserror (s_sys_lseek); - answer = scm_long2num (got); - SCM_ALLOW_INTS; - return answer; -} - - -SCM_PROC (s_sys_dup, "dup", 1, 1, 0, scm_sys_dup); - -SCM -scm_sys_dup (oldfd, newfd) - SCM oldfd; - SCM newfd; -{ - SCM answer; - int fd; - int nfd; - int (*fn)(); - - SCM_ASSERT (SCM_NIMP (oldfd) && SCM_FD_P (oldfd), oldfd, SCM_ARG1, s_sys_dup); - SCM_ASSERT (SCM_UNBNDP (newfd) || SCM_INUMP (newfd), newfd, SCM_ARG2, s_sys_dup); - fd = SCM_FD (oldfd); - nfd = (SCM_INUMP (newfd) ? SCM_INUM (newfd) : -1); - - SCM_DEFER_INTS; - fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2); - nfd = fn (fd, nfd); - if (nfd == -1) - scm_syserror (s_sys_dup); - answer = SCM_MAKINUM (nfd); - SCM_ALLOW_INTS; - return answer; -} - - - -/* {Files} - */ - -SCM_SYMBOL (scm_sym_regular, "regular"); -SCM_SYMBOL (scm_sym_directory, "directory"); -SCM_SYMBOL (scm_sym_symlink, "symlink"); -SCM_SYMBOL (scm_sym_block_special, "block-special"); -SCM_SYMBOL (scm_sym_char_special, "char-special"); -SCM_SYMBOL (scm_sym_fifo, "fifo"); -SCM_SYMBOL (scm_sym_sock, "socket"); -SCM_SYMBOL (scm_sym_unknown, "unknown"); - -static SCM scm_stat2scm SCM_P ((struct stat *stat_temp)); - -static SCM -scm_stat2scm (stat_temp) - struct stat *stat_temp; -{ - SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - - ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev); - ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino); - ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode); - ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink); - ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid); - ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid); -#ifdef HAVE_ST_RDEV - ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev); -#else - ve[6] = SCM_BOOL_F; -#endif - ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size); - ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime); - ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime); - ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime); -#ifdef HAVE_ST_BLKSIZE - ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize); -#else - ve[11] = scm_ulong2num (4096L); -#endif -#ifdef HAVE_ST_BLOCKS - ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks); -#else - ve[12] = SCM_BOOL_F; -#endif - { - int mode = stat_temp->st_mode; - - if (S_ISREG (mode)) - ve[13] = scm_sym_regular; - else if (S_ISDIR (mode)) - ve[13] = scm_sym_directory; - else if (S_ISLNK (mode)) - ve[13] = scm_sym_symlink; - else if (S_ISBLK (mode)) - ve[13] = scm_sym_block_special; - else if (S_ISCHR (mode)) - ve[13] = scm_sym_char_special; - else if (S_ISFIFO (mode)) - ve[13] = scm_sym_fifo; - else if (S_ISSOCK (mode)) - ve[13] = scm_sym_sock; - else - ve[13] = scm_sym_unknown; - - ve[14] = SCM_MAKINUM ((~S_IFMT) & mode); - - /* the layout of the bits in ve[14] is intended to be portable. - If there are systems that don't follow the usual convention, - the following could be used: - - tmp = 0; - if (S_ISUID & mode) tmp += 1; - tmp <<= 1; - if (S_IRGRP & mode) tmp += 1; - tmp <<= 1; - if (S_ISVTX & mode) tmp += 1; - tmp <<= 1; - if (S_IRUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IWUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IXUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IWGRP & mode) tmp += 1; - tmp <<= 1; - if (S_IXGRP & mode) tmp += 1; - tmp <<= 1; - if (S_IROTH & mode) tmp += 1; - tmp <<= 1; - if (S_IWOTH & mode) tmp += 1; - tmp <<= 1; - if (S_IXOTH & mode) tmp += 1; - - ve[14] = SCM_MAKINUM (tmp); - - */ - } - - return ans; -} - -SCM_PROC (s_sys_stat, "stat", 1, 0, 0, scm_sys_stat); - -SCM -scm_sys_stat (fd_or_path) - SCM fd_or_path; -{ - int rv = 1; - struct stat stat_temp; - - if (SCM_INUMP (fd_or_path)) - { - rv = SCM_INUM (fd_or_path); - SCM_SYSCALL (rv = fstat (rv, &stat_temp)); - } - else if (SCM_NIMP (fd_or_path) && SCM_FD_P (fd_or_path)) - { - rv = SCM_FD (fd_or_path); - SCM_SYSCALL (rv = fstat (rv, &stat_temp)); - } - else - { - SCM_ASSERT (SCM_NIMP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat); - SCM_ASSERT (SCM_ROSTRINGP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat); - if (SCM_ROSTRINGP (fd_or_path)) - { - if (SCM_SUBSTRP (fd_or_path)) - fd_or_path = scm_makfromstr (SCM_ROCHARS (fd_or_path), SCM_ROLENGTH (fd_or_path), 0); - SCM_SYSCALL (rv = stat (SCM_CHARS (fd_or_path), &stat_temp)); - } - - } - if (rv != 0) - scm_syserror_msg (s_sys_stat, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - fd_or_path, - SCM_UNDEFINED)); - return scm_stat2scm (&stat_temp); -} - - - -/* {Modifying Directories} - */ - -SCM_PROC (s_sys_link, "link", 2, 0, 0, scm_sys_link); - -SCM -scm_sys_link (oldpath, newpath) - SCM oldpath; - SCM newpath; -{ - int val; - - SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link); - if (SCM_SUBSTRP (oldpath)) - oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0); - SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_sys_link); - if (SCM_SUBSTRP (newpath)) - newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0); - SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); - if (val != 0) - scm_syserror (s_sys_link); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_rename, "rename-file", 2, 0, 0, scm_sys_rename); - -SCM -scm_sys_rename (oldname, newname) - SCM oldname; - SCM newname; -{ - int rv; - SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_sys_rename); - SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename); -#ifdef HAVE_RENAME - SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname))); - if (rv != 0) - scm_syserror (s_sys_rename); - return SCM_UNSPECIFIED; -#else - SCM_DEFER_INTS; - SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname))); - if (rv == 0) - { - SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));; - if (rv != 0) - /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (SCM_CHARS (newname))); - } - SCM_ALLOW_INTS; - if (rv != 0) - scm_syserror (s_sys_rename); - return SCM_UNSPECIFIED; -#endif -} - - -SCM_PROC(s_sys_delete_file, "delete-file", 1, 0, 0, scm_sys_delete_file); - -SCM -scm_sys_delete_file (str) - SCM str; -{ - int ans; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_delete_file); - SCM_SYSCALL (ans = unlink (SCM_CHARS (str))); - if (ans != 0) - scm_syserror (s_sys_delete_file); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_mkdir, "mkdir", 1, 1, 0, scm_sys_mkdir); - -SCM -scm_sys_mkdir (path, mode) - SCM path; - SCM mode; -{ -#ifdef HAVE_MKDIR - int rv; - mode_t mask; - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_mkdir); - if (SCM_UNBNDP (mode)) - { - mask = umask (0); - umask (mask); - SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), 0777 ^ mask)); - } - else - { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir); - SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode))); - } - if (rv != 0) - scm_syserror (s_sys_mkdir); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_mkdir); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_rmdir, "rmdir", 1, 0, 0, scm_sys_rmdir); - -SCM -scm_sys_rmdir (path) - SCM path; -{ -#ifdef HAVE_RMDIR - int val; - - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir); - SCM_SYSCALL (val = rmdir (SCM_CHARS (path))); - if (val != 0) - scm_syserror (s_sys_rmdir); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_rmdir); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -/* {Examining Directories} - */ - -long scm_tc16_dir; - -SCM_PROC (s_sys_opendir, "opendir", 1, 0, 0, scm_sys_opendir); - -SCM -scm_sys_opendir (dirname) - SCM dirname; -{ - DIR *ds; - SCM dir; - SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_sys_opendir); - SCM_NEWCELL (dir); - SCM_DEFER_INTS; - SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname))); - if (ds == NULL) - scm_syserror (s_sys_opendir); - SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN); - SCM_SETCDR (dir, ds); - SCM_ALLOW_INTS; - return dir; -} - - -SCM_PROC (s_sys_readdir, "readdir", 1, 0, 0, scm_sys_readdir); - -SCM -scm_sys_readdir (port) - SCM port; -{ - struct dirent *rdent; - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_sys_readdir); - errno = 0; - SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port))); - SCM_ALLOW_INTS; - if (errno != 0) - scm_syserror (s_sys_readdir); - return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) - : SCM_EOF_VAL); -} - - - -SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir); - -SCM -scm_rewinddir (port) - SCM port; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir); - rewinddir ((DIR *) SCM_CDR (port)); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_closedir, "closedir", 1, 0, 0, scm_sys_closedir); - -SCM -scm_sys_closedir (port) - SCM port; -{ - int sts; - - SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir); - SCM_DEFER_INTS; - if (SCM_CLOSEDP (port)) - { - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; - } - SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port))); - if (sts != 0) - scm_syserror (s_sys_closedir); - SCM_SETCAR (port, scm_tc16_dir); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - - -static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); - -static int -scm_dir_print (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (sexp, port, "directory"); - return 1; -} - - -static scm_sizet scm_dir_free SCM_P ((SCM p)); - -static scm_sizet -scm_dir_free (p) - SCM p; -{ - if (SCM_OPENP (p)) - closedir ((DIR *) SCM_CDR (p)); - return 0; -} - -static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0}; - - -/* {Navigating Directories} - */ - - -SCM_PROC (s_sys_chdir, "chdir", 1, 0, 0, scm_sys_chdir); - -SCM -scm_sys_chdir (str) - SCM str; -{ - int ans; - - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir); - SCM_SYSCALL (ans = chdir (SCM_CHARS (str))); - if (ans != 0) - scm_syserror (s_sys_chdir); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_getcwd, "getcwd", 0, 0, 0, scm_sys_getcwd); - -SCM -scm_sys_getcwd () -{ -#ifdef HAVE_GETCWD - char *rv; - - scm_sizet size = 100; - char *wd; - SCM result; - - SCM_DEFER_INTS; - wd = scm_must_malloc (size, s_sys_getcwd); - while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE) - { - scm_must_free (wd); - size *= 2; - wd = scm_must_malloc (size, s_sys_getcwd); - } - if (rv == 0) - scm_syserror (s_sys_getcwd); - result = scm_makfromstr (wd, strlen (wd), 0); - scm_must_free (wd); - SCM_ALLOW_INTS; - return result; -#else - scm_sysmissing (s_sys_getcwd); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - - - -static void fill_select_type SCM_P ((SELECT_TYPE * set, SCM list)); - -static void -fill_select_type (set, list) - SELECT_TYPE * set; - SCM list; -{ - while (list != SCM_EOL) - { - if ( SCM_NIMP (SCM_CAR (list)) - && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list))) - && SCM_OPPORTP (SCM_CAR (list))) - FD_SET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set); - else if (SCM_INUMP (SCM_CAR (list))) - FD_SET (SCM_INUM (SCM_CAR (list)), set); - else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list))) - FD_SET (SCM_FD (SCM_CAR (list)), set); - list = SCM_CDR (list); - } -} - - -static SCM retrieve_select_type SCM_P ((SELECT_TYPE * set, SCM list)); - -static SCM -retrieve_select_type (set, list) - SELECT_TYPE * set; - SCM list; -{ - SCM answer; - answer = SCM_EOL; - while (list != SCM_EOL) - { - if ( SCM_NIMP (SCM_CAR (list)) - && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list))) - && SCM_OPPORTP (SCM_CAR (list))) - { - if (FD_ISSET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - else if (SCM_INUMP (SCM_CAR (list))) - { - if (FD_ISSET (SCM_INUM (SCM_CAR (list)), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list))) - { - if (FD_ISSET (SCM_FD (SCM_CAR (list)), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - list = SCM_CDR (list); - } - return answer; -} - - -/* {Checking for events} - */ - -SCM_PROC (s_sys_select, "select", 3, 2, 0, scm_sys_select); - -SCM -scm_sys_select (reads, writes, excepts, secs, msecs) - SCM reads; - SCM writes; - SCM excepts; - SCM secs; - SCM msecs; -{ -#ifdef HAVE_SELECT - struct timeval timeout; - struct timeval * time_p; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - int sreturn; - - SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_sys_select); - SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_sys_select); - SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_sys_select); - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - fill_select_type (&read_set, reads); - fill_select_type (&write_set, writes); - fill_select_type (&except_set, excepts); - - if (SCM_UNBNDP (secs)) - time_p = 0; - else - { - SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_sys_select); - if (SCM_UNBNDP (msecs)) - msecs = SCM_INUM0; - else - SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_sys_select); - - timeout.tv_sec = SCM_INUM (secs); - timeout.tv_usec = 1000 * SCM_INUM (msecs); - time_p = &timeout; - } - - SCM_DEFER_INTS; - sreturn = select (SELECT_SET_SIZE, - &read_set, &write_set, &except_set, time_p); - if (sreturn < 0) - scm_syserror (s_sys_select); - SCM_ALLOW_INTS; - return scm_listify (retrieve_select_type (&read_set, reads), - retrieve_select_type (&write_set, writes), - retrieve_select_type (&except_set, excepts), - SCM_UNDEFINED); -#else - scm_sysmissing (s_sys_select); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -/* Check if FILE has characters waiting to be read. */ - -#ifdef __IBMC__ -# define MSDOS -#endif -#ifdef MSDOS -# ifndef GO32 -# include <io.h> -# include <conio.h> - -int -scm_input_waiting_p (f, caller) - FILE *f; - char *caller; -{ - if (feof (f)) - return 1; - if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin)))) - return kbhit (); - return -1; -} - -# endif -#else -# ifdef _DCC -# include <ioctl.h> -# else -# ifndef AMIGA -# ifndef vms -# ifdef MWC -# include <sys/io.h> -# else -# ifndef THINK_C -# ifndef ARM_ULIB -# include <sys/ioctl.h> -# endif -# endif -# endif -# endif -# endif -# endif - -int -scm_input_waiting_p (f, caller) - FILE *f; - char *caller; -{ - /* Can we return an end-of-file character? */ - if (feof (f)) - return 1; - - /* Do we have characters in the stdio buffer? */ -# ifdef FILE_CNT_FIELD - if (f->FILE_CNT_FIELD > 0) - return 1; -# else -# ifdef FILE_CNT_GPTR - if (f->_gptr != f->_egptr) - return 1; -# else -# ifdef FILE_CNT_READPTR - if (f->_IO_read_end != f->_IO_read_ptr) - return 1; -# else - Configure.in could not guess the name of the correct field in a FILE *. - This function needs to be ported to your system. - It should return zero iff no characters are waiting to be read.; -# endif -# endif -# endif - - /* Is the file prepared to deliver input? */ -# ifdef FIONREAD - { - long remir; - ioctl(fileno(f), FIONREAD, &remir); - return remir; - } -# else -# ifdef HAVE_SELECT - { - struct timeval timeout; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - int fno = fileno ((FILE *)f); - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - FD_SET (fno, &read_set); - - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - SCM_DEFER_INTS; - if (select (SELECT_SET_SIZE, - &read_set, &write_set, &except_set, &timeout) - < 0) - scm_syserror (caller); - SCM_ALLOW_INTS; - return FD_ISSET (fno, &read_set); - } -# else - return -1; -# endif -# endif -} -#endif - - -/* {Symbolic Links} - */ - -SCM_PROC (s_sys_symlink, "symlink", 2, 0, 0, scm_sys_symlink); - -SCM -scm_sys_symlink(oldpath, newpath) - SCM oldpath; - SCM newpath; -{ -#ifdef HAVE_SYMLINK - int val; - - SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink); - SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink); - SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath))); - if (val != 0) - scm_syserror (s_sys_symlink); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_symlink); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_readlink, "readlink", 1, 0, 0, scm_sys_readlink); - -SCM -scm_sys_readlink(path) - SCM path; -{ -#ifdef HAVE_READLINK - scm_sizet rv; - scm_sizet size = 100; - char *buf; - SCM result; - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_sys_readlink); - SCM_DEFER_INTS; - buf = scm_must_malloc (size, s_sys_readlink); - while ((rv = readlink (SCM_CHARS (path), buf, (scm_sizet) size)) == size) - { - scm_must_free (buf); - size *= 2; - buf = scm_must_malloc (size, s_sys_readlink); - } - if (rv == -1) - scm_syserror (s_sys_readlink); - result = scm_makfromstr (buf, rv, 0); - scm_must_free (buf); - SCM_ALLOW_INTS; - return result; -#else - scm_sysmissing (s_sys_readlink); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_lstat, "lstat", 1, 0, 0, scm_sys_lstat); - -SCM -scm_sys_lstat(str) - SCM str; -{ -#ifdef HAVE_LSTAT - int rv; - struct stat stat_temp; - - SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat); - SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp)); - if (rv != 0) - scm_syserror_msg (s_sys_lstat, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - str, - SCM_UNDEFINED)); - return scm_stat2scm(&stat_temp); -#else - scm_sysmissing (s_sys_lstat); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_copy_file, "copy-file", 2, 0, 0, scm_sys_copy_file); - -SCM -scm_sys_copy_file (oldfile, newfile) - SCM oldfile; - SCM newfile; -{ - int oldfd, newfd; - int n; - char buf[BUFSIZ]; /* this space could be shared. */ - struct stat oldstat; - - SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_sys_copy_file); - if (SCM_SUBSTRP (oldfile)) - oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0); - SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_sys_copy_file); - if (SCM_SUBSTRP (newfile)) - newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0); - if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) - scm_syserror (s_sys_copy_file); - SCM_DEFER_INTS; - oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); - if (oldfd == -1) - scm_syserror (s_sys_copy_file); - - /* use POSIX flags instead of 07777?. */ - newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, - oldstat.st_mode & 07777); - if (newfd == -1) - scm_syserror (s_sys_copy_file); - - while ((n = read (oldfd, buf, sizeof buf)) > 0) - if (write (newfd, buf, n) != n) - { - close (oldfd); - close (newfd); - scm_syserror (s_sys_copy_file); - } - close (oldfd); - if (close (newfd) == -1) - scm_syserror (s_sys_copy_file); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_filesys () -{ - scm_add_feature ("i/o-extensions"); - - scm_tc16_fd = scm_newsmob (&fd_smob); - scm_tc16_dir = scm_newsmob (&dir_smob); - -#include "filesys.x" -} diff --git a/libguile/filesys.h b/libguile/filesys.h deleted file mode 100644 index ff7a28664..000000000 --- a/libguile/filesys.h +++ /dev/null @@ -1,105 +0,0 @@ -/* classes: h_files */ - -#ifndef FILESYSH -#define FILESYSH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "libguile/__scm.h" - - - -extern long scm_tc16_fd; - -#define SCM_FD_P(x) (SCM_TYP16(x)==(scm_tc16_fd)) -#define SCM_FD_FLAGS(x) (SCM_CAR(x) >> 16) -#define SCM_FD(x) ((int)SCM_CDR (x)) - -enum scm_fd_flags -{ - scm_fd_is_open = 1, - scm_close_fd_on_gc = 2 -}; - - - - -extern long scm_tc16_dir; -#define SCM_DIRP(x) (SCM_TYP16(x)==(scm_tc16_dir)) -#define SCM_OPDIRP(x) (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN)) - - - - -extern SCM scm_sys_chown SCM_P ((SCM path, SCM owner, SCM group)); -extern SCM scm_sys_chmod SCM_P ((SCM port_or_path, SCM mode)); -extern SCM scm_umask SCM_P ((SCM mode)); -extern SCM scm_intern_fd SCM_P ((int fd, int flags)); -extern SCM scm_sys_open SCM_P ((SCM path, SCM flags, SCM mode)); -extern SCM scm_sys_create SCM_P ((SCM path, SCM mode)); -extern SCM scm_sys_close SCM_P ((SCM sfd)); -extern SCM scm_sys_write_fd SCM_P ((SCM sfd, SCM buf)); -extern SCM scm_sys_read_fd SCM_P ((SCM sfd, SCM buf, SCM offset, SCM length)); -extern SCM scm_sys_lseek SCM_P ((SCM sfd, SCM offset, SCM whence)); -extern SCM scm_sys_dup SCM_P ((SCM oldfd, SCM newfd)); -extern SCM scm_sys_stat SCM_P ((SCM fd_or_path)); -extern SCM scm_sys_link SCM_P ((SCM oldpath, SCM newpath)); -extern SCM scm_sys_rename SCM_P ((SCM oldname, SCM newname)); -extern SCM scm_sys_delete_file SCM_P ((SCM str)); -extern SCM scm_sys_mkdir SCM_P ((SCM path, SCM mode)); -extern SCM scm_sys_rmdir SCM_P ((SCM path)); -extern SCM scm_sys_opendir SCM_P ((SCM dirname)); -extern SCM scm_sys_readdir SCM_P ((SCM port)); -extern SCM scm_rewinddir SCM_P ((SCM port)); -extern SCM scm_sys_closedir SCM_P ((SCM port)); -extern SCM scm_sys_chdir SCM_P ((SCM str)); -extern SCM scm_sys_getcwd SCM_P ((void)); -extern SCM scm_sys_select SCM_P ((SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)); -extern int scm_input_waiting_p SCM_P ((FILE *file, char *caller)); -extern SCM scm_sys_symlink SCM_P ((SCM oldpath, SCM newpath)); -extern SCM scm_sys_readlink SCM_P ((SCM path)); -extern SCM scm_sys_lstat SCM_P ((SCM str)); -extern SCM scm_sys_copy_file SCM_P ((SCM oldfile, SCM newfile)); -extern void scm_init_filesys SCM_P ((void)); - -#endif /* FILESYSH */ diff --git a/libguile/fports.c b/libguile/fports.c deleted file mode 100644 index 928aeeff5..000000000 --- a/libguile/fports.c +++ /dev/null @@ -1,400 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "markers.h" - -#include "fports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -scm_sizet fwrite (); -#endif - - -#ifdef __IBMC__ -#include <io.h> -#include <direct.h> -#else -#ifndef MSDOS -#ifndef ultrix -#ifndef vms -#ifdef _DCC -#include <ioctl.h> -#define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0) -#else -#ifdef MWC -#include <sys/io.h> -#else -#ifndef THINK_C -#ifndef ARM_ULIB -#include <sys/ioctl.h> -#endif -#endif -#endif -#endif -#endif -#endif -#endif -#endif - - -/* {Ports - file ports} - * - */ - -/* should be called with SCM_DEFER_INTS active */ - -SCM -scm_setbuf0 (port) - SCM port; -{ -#ifndef NOSETBUF -#ifndef MSDOS -#ifdef FIONREAD -#ifndef ultrix - SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); -#endif -#endif -#endif -#endif - return SCM_UNSPECIFIED; -} - -/* Return the flags that characterize a port based on the mode - * string used to open a file for that port. - * - * See PORT FLAGS in scm.h - */ - -long -scm_mode_bits (modes) - char *modes; -{ - return (SCM_OPN - | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) - | ( strchr (modes, 'w') - || strchr (modes, 'a') - || strchr (modes, '+') ? SCM_WRTNG : 0) - | (strchr (modes, '0') ? SCM_BUF0 : 0)); -} - - -/* scm_open_file - * Return a new port open on a given file. - * - * The mode string must match the pattern: [rwa+]** which - * is interpreted in the usual unix way. - * - * Return the new port. - */ -SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file); - -SCM -scm_open_file (filename, modes) - SCM filename; - SCM modes; -{ - SCM port; - FILE *f; - char *file; - char *mode; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - - file = SCM_ROCHARS (filename); - mode = SCM_ROCHARS (modes); - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - SCM_SYSCALL (f = fopen (file, mode)); - if (!f) - { - scm_syserror_msg (s_open_file, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - filename, - SCM_UNDEFINED)); - } - else - { - struct scm_port_table * pt; - - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode)); - SCM_SETSTREAM (port, (SCM) f); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = filename; - } - SCM_ALLOW_INTS; - return port; -} - - -/* Build a Scheme port from an open stdio port, FILE. - MODE indicates whether FILE is open for reading or writing; it uses - the same notation as open-file's second argument. - If NAME is non-zero, use it as the port's filename. - - scm_stdio_to_port sets the revealed count for FILE's file - descriptor to 1, so that FILE won't be closed when the port object - is GC'd. */ -SCM -scm_stdio_to_port (file, mode, name) - FILE *file; - char *mode; - char *name; -{ - long mode_bits = scm_mode_bits (mode); - SCM port; - struct scm_port_table * pt; - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - { - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, (scm_tc16_fport | mode_bits)); - SCM_SETSTREAM (port, (SCM) file); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name); - } - SCM_ALLOW_INTS; - scm_set_port_revealed_x (port, SCM_MAKINUM (1)); - return port; -} - - -/* Return the mode flags from an open port. - * Some modes such as "append" are only used when opening - * a file and are not returned here. */ - -SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); - -SCM -scm_port_mode (port) - SCM port; -{ - char modes[3]; - modes[0] = '\0'; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); - if (SCM_CAR (port) & SCM_RDNG) { - if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "r+"); - else - strcpy (modes, "r"); - } - else if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "w"); - if (SCM_CAR (port) & SCM_BUF0) - strcat (modes, "0"); - return scm_makfromstr (modes, strlen (modes), 0); -} - - - -static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinfport (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - SCM name; - char * c; - if (SCM_CLOSEDP (exp)) - { - c = "file"; - } - else - { - name = SCM_PTAB_ENTRY (exp)->file_name; - if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) - c = SCM_ROCHARS (name); - else - c = "file"; - } - - scm_prinport (exp, port, c); - return !0; -} - - - -static int scm_fgetc SCM_P ((FILE * s)); - -static int -scm_fgetc (s) - FILE * s; -{ - if (feof (s)) - return EOF; - else - return fgetc (s); -} - -#ifdef vms - -static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port)); - -static scm_sizet -pwrite (ptr, size, nitems, port) - char *ptr; - scm_sizet size, nitems; - FILE *port; -{ - scm_sizet len = size * nitems; - scm_sizet i = 0; - for (; i < len; i++) - putc (ptr[i], port); - return len; -} - -#define ffwrite pwrite -#else -#define ffwrite fwrite -#endif - - -/* This otherwise pointless code helps some poor - * crippled C compilers cope with life. - */ - -static int local_fclose SCM_P ((FILE *fp)); - -static int -local_fclose (fp) - FILE * fp; -{ - return fclose (fp); -} - -static int local_fflush SCM_P ((FILE *fp)); - -static int -local_fflush (fp) - FILE * fp; -{ - return fflush (fp); -} - -static int local_fputc SCM_P ((int c, FILE *fp)); - -static int -local_fputc (c, fp) - int c; - FILE * fp; -{ - return fputc (c, fp); -} - -static int local_fputs SCM_P ((char *s, FILE *fp)); - -static int -local_fputs (s, fp) - char * s; - FILE * fp; -{ - return fputs (s, fp); -} - -static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp)); - -static scm_sizet -local_ffwrite (ptr, size, nitems, fp) - void * ptr; - int size; - int nitems; - FILE * fp; -{ - return ffwrite (ptr, size, nitems, fp); -} - - -scm_ptobfuns scm_fptob = -{ - scm_mark0, - (int (*) SCM_P ((SCM))) local_fclose, - prinfport, - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - (int (*) SCM_P ((SCM))) local_fclose -}; - -/* {Pipe ports} - */ -scm_ptobfuns scm_pipob = -{ - scm_mark0, - 0, /* replaced by pclose in scm_init_ioext() */ - 0, /* replaced by prinpipe in scm_init_ioext() */ - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - 0 -}; /* replaced by pclose in scm_init_ioext() */ - -void -scm_init_fports () -{ -#include "fports.x" -} diff --git a/libguile/fports.h b/libguile/fports.h deleted file mode 100644 index 13802d345..000000000 --- a/libguile/fports.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef FPORTSH -#define FPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/ports.h" - - - -extern scm_ptobfuns scm_fptob; -extern scm_ptobfuns scm_pipob; - - - -extern SCM scm_setbuf0 SCM_P ((SCM port)); -extern long scm_mode_bits SCM_P ((char *modes)); -extern SCM scm_open_file SCM_P ((SCM filename, SCM modes)); -extern SCM scm_stdio_to_port SCM_P ((FILE *file, char *name, char *modes)); -extern SCM scm_port_mode SCM_P ((SCM port)); -extern void scm_init_fports SCM_P ((void)); - -#endif /* FPORTSH */ diff --git a/libguile/gc.c b/libguile/gc.c deleted file mode 100644 index cd4a249d7..000000000 --- a/libguile/gc.c +++ /dev/null @@ -1,1825 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "stime.h" -#include "stackchk.h" -#include "struct.h" -#include "genio.h" -#include "weaks.h" -#include "smob.h" -#include "unif.h" -#include "async.h" - -#include "gc.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef __STDC__ -#include <stdarg.h> -#define var_start(x, y) va_start(x, y) -#else -#include <varargs.h> -#define var_start(x, y) va_start(x) -#endif - - -/* {heap tuning parameters} - * - * These are parameters for controlling memory allocation. The heap - * is the area out of which scm_cons, and object headers are allocated. - * - * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a - * 64 bit machine. The units of the _SIZE parameters are bytes. - * Cons pairs and object headers occupy one heap cell. - * - * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is - * allocated initially the heap will grow by half its current size - * each subsequent time more heap is needed. - * - * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE - * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more - * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code - * is in scm_init_storage() and alloc_some_heap() in sys.c - * - * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by - * SCM_EXPHEAP(scm_heap_size) when more heap is needed. - * - * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap - * is needed. - * - * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will - * trigger a GC. - * - * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be - * reclaimed by a GC triggered by must_malloc. If less than this is - * reclaimed, the trigger threshold is raised. [I don't know what a - * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to - * work around a oscillation that caused almost constant GC.] - */ - -#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell)) -#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell)) -#ifdef _QC -# define SCM_HEAP_SEG_SIZE 32768L -#else -# ifdef sequent -# define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell)) -# else -# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell)) -# endif -#endif -#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2) -#define SCM_INIT_MALLOC_LIMIT 100000 -#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) - -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner - bounds for allocated storage */ - -#ifdef PROT386 -/*in 386 protected mode we must only adjust the offset */ -# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7)) -# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p)) -#else -# ifdef _UNICOS -# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L)) -# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p)) -# else -# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L)) -# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p)) -# endif /* UNICOS */ -#endif /* PROT386 */ - - - -/* scm_freelist - * is the head of freelist of cons pairs. - */ -SCM scm_freelist = SCM_EOL; - -/* scm_mtrigger - * is the number of bytes of must_malloc allocation needed to trigger gc. - */ -long scm_mtrigger; - - -/* scm_gc_heap_lock - * If set, don't expand the heap. Set only during gc, during which no allocation - * is supposed to take place anyway. - */ -int scm_gc_heap_lock = 0; - -/* GC Blocking - * Don't pause for collection if this is set -- just - * expand the heap. - */ - -int scm_block_gc = 1; - -/* If fewer than MIN_GC_YIELD cells are recovered during a garbage - * collection (GC) more space is allocated for the heap. - */ -#define MIN_GC_YIELD (scm_heap_size/4) - -/* During collection, this accumulates objects holding - * weak references. - */ -SCM *scm_weak_vectors; -int scm_weak_size; -int scm_n_weak; - -/* GC Statistics Keeping - */ -unsigned long scm_cells_allocated = 0; -unsigned long scm_mallocated = 0; -unsigned long scm_gc_cells_collected; -unsigned long scm_gc_malloc_collected; -unsigned long scm_gc_ports_collected; -unsigned long scm_gc_rt; -unsigned long scm_gc_time_taken = 0; - -SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); -SCM_SYMBOL (sym_heap_size, "cell-heap-size"); -SCM_SYMBOL (sym_mallocated, "bytes-malloced"); -SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); -SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); -SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); - - -struct scm_heap_seg_data -{ - /* lower and upper bounds of the segment */ - SCM_CELLPTR bounds[2]; - - /* address of the head-of-freelist pointer for this segment's cells. - All segments usually point to the same one, scm_freelist. */ - SCM *freelistp; - - /* number of SCM words per object in this segment */ - int ncells; - - /* If SEG_DATA->valid is non-zero, the conservative marking - functions will apply SEG_DATA->valid to the purported pointer and - SEG_DATA, and mark the object iff the function returns non-zero. - At the moment, I don't think anyone uses this. */ - int (*valid) (); -}; - - - - -static void scm_mark_weak_vector_spines SCM_P ((void)); -static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *)); -static void alloc_some_heap SCM_P ((int, SCM *)); - - - -/* Debugging functions. */ - -#ifdef DEBUG_FREELIST - -/* Return the number of the heap segment containing CELL. */ -static int -which_seg (SCM cell) -{ - int i; - - for (i = 0; i < scm_n_heap_segs; i++) - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell) - && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell)) - return i; - fprintf (stderr, "which_seg: can't find segment containing cell %lx\n", - cell); - abort (); -} - - -SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list); -SCM -scm_map_free_list () -{ - int last_seg = -1, count = 0; - SCM f; - - fprintf (stderr, "%d segments total\n", scm_n_heap_segs); - for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f)) - { - int this_seg = which_seg (f); - - if (this_seg != last_seg) - { - if (last_seg != -1) - fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); - last_seg = this_seg; - count = 0; - } - count++; - } - if (last_seg != -1) - fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); - - fflush (stderr); - - return SCM_UNSPECIFIED; -} - - -/* Number of calls to SCM_NEWCELL since startup. */ -static unsigned long scm_newcell_count; - -/* Search freelist for anything that isn't marked as a free cell. - Abort if we find something. */ -static void -scm_check_freelist () -{ - SCM f; - int i = 0; - - for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++) - if (SCM_CAR (f) != (SCM) scm_tc_free_cell) - { - fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n", - scm_newcell_count, i); - fflush (stderr); - abort (); - } -} - -static int scm_debug_check_freelist = 0; -void -scm_debug_newcell (SCM *into) -{ - scm_newcell_count++; - if (scm_debug_check_freelist) - scm_check_freelist (); - - /* The rest of this is supposed to be identical to the SCM_NEWCELL - macro. */ - if (SCM_IMP (scm_freelist)) - *into = scm_gc_for_newcell (); - else - { - *into = scm_freelist; - scm_freelist = SCM_CDR (scm_freelist); - ++scm_cells_allocated; - } -} - -#endif /* DEBUG_FREELIST */ - - - -/* {Scheme Interface to GC} - */ - -SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats); -SCM -scm_gc_stats () -{ - int i; - int n; - SCM heap_segs; - SCM local_scm_mtrigger; - SCM local_scm_mallocated; - SCM local_scm_heap_size; - SCM local_scm_cells_allocated; - SCM local_scm_gc_time_taken; - SCM answer; - - SCM_DEFER_INTS; - scm_block_gc = 1; - retry: - heap_segs = SCM_EOL; - n = scm_n_heap_segs; - for (i = scm_n_heap_segs; i--; ) - heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]), - scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])), - heap_segs); - if (scm_n_heap_segs != n) - goto retry; - scm_block_gc = 0; - - local_scm_mtrigger = scm_mtrigger; - local_scm_mallocated = scm_mallocated; - local_scm_heap_size = scm_heap_size; - local_scm_cells_allocated = scm_cells_allocated; - local_scm_gc_time_taken = scm_gc_time_taken; - - answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), - scm_cons (sym_heap_segments, heap_segs), - SCM_UNDEFINED); - SCM_ALLOW_INTS; - return answer; -} - - -void -scm_gc_start (what) - char *what; -{ - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); - scm_gc_cells_collected = 0; - scm_gc_malloc_collected = 0; - scm_gc_ports_collected = 0; -} - -void -scm_gc_end () -{ - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; - scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt; - scm_take_signal (SCM_GC_SIGNAL); -} - - -SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr); -SCM -scm_object_addr (obj) - SCM obj; -{ - return scm_ulong2num ((unsigned long)obj); -} - - -SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc); -SCM -scm_gc () -{ - SCM_DEFER_INTS; - scm_igc ("call"); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - -/* {C Interface For When GC is Triggered} - */ - -void -scm_gc_for_alloc (ncells, freelistp) - int ncells; - SCM * freelistp; -{ - SCM_REDEFER_INTS; - scm_igc ("cells"); - if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp)) - { - alloc_some_heap (ncells, freelistp); - } - SCM_REALLOW_INTS; -} - - -SCM -scm_gc_for_newcell () -{ - SCM fl; - scm_gc_for_alloc (1, &scm_freelist); - fl = scm_freelist; - scm_freelist = SCM_CDR (fl); - return fl; -} - -void -scm_igc (what) - char *what; -{ - int j; - -#ifdef USE_THREADS - /* During the critical section, only the current thread may run. */ - SCM_THREAD_CRITICAL_SECTION_START; -#endif - - scm_gc_start (what); - if (!scm_stack_base || scm_block_gc) - { - scm_gc_end (); - return; - } - - ++scm_gc_heap_lock; - scm_n_weak = 0; - - /* unprotect any struct types with no instances */ -#if 0 - { - SCM type_list; - SCM * pos; - - pos = &scm_type_obj_list; - type_list = scm_type_obj_list; - while (type_list != SCM_EOL) - if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt]) - { - pos = SCM_CDRLOC (type_list); - type_list = SCM_CDR (type_list); - } - else - { - *pos = SCM_CDR (type_list); - type_list = SCM_CDR (type_list); - } - } -#endif - - /* flush dead entries from the continuation stack */ - { - int x; - int bound; - SCM * elts; - elts = SCM_VELTS (scm_continuation_stack); - bound = SCM_LENGTH (scm_continuation_stack); - x = SCM_INUM (scm_continuation_stack_ptr); - while (x < bound) - { - elts[x] = SCM_BOOL_F; - ++x; - } - } - -#ifndef USE_THREADS - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_vector_set_length_x. - */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 + - sizeof scm_save_regs_gc_mark) - / sizeof (SCM_STACKITEM))); - - { - /* stack_len is long rather than scm_sizet in order to guarantee that - &stack_len is long aligned */ -#ifdef SCM_STACK_GROWS_UP -#ifdef nosve - long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base; -#else - long stack_len = scm_stack_size (scm_stack_base); -#endif - scm_mark_locations (scm_stack_base, (scm_sizet) stack_len); -#else -#ifdef nosve - long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len); -#else - long stack_len = scm_stack_size (scm_stack_base); -#endif - scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len); -#endif - } - -#else /* USE_THREADS */ - - /* Mark every thread's stack and registers */ - scm_threads_mark_stacks(); - -#endif /* USE_THREADS */ - - /* FIXME: insert a phase to un-protect string-data preserved - * in scm_vector_set_length_x. - */ - - j = SCM_NUM_PROTECTS; - while (j--) - scm_gc_mark (scm_sys_protects[j]); - -#ifndef USE_THREADS - scm_gc_mark (scm_root->handle); -#endif - - scm_mark_weak_vector_spines (); - - scm_gc_sweep (); - - --scm_gc_heap_lock; - scm_gc_end (); - -#ifdef USE_THREADS - SCM_THREAD_CRITICAL_SECTION_END; -#endif -} - - -/* {Mark/Sweep} - */ - - - -/* Mark an object precisely. - */ -void -scm_gc_mark (p) - SCM p; -{ - register long i; - register SCM ptr; - - ptr = p; - -gc_mark_loop: - if (SCM_IMP (ptr)) - return; - -gc_mark_nimp: - if (SCM_NCELLP (ptr)) - scm_wta (ptr, "rogue pointer in ", "heap"); - - switch (SCM_TYP7 (ptr)) - { - case scm_tcs_cons_nimcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */ - { - ptr = SCM_CAR (ptr); - goto gc_mark_nimp; - } - scm_gc_mark (SCM_CAR (ptr)); - ptr = SCM_GCCDR (ptr); - goto gc_mark_nimp; - case scm_tcs_cons_imcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - case scm_tcs_cons_gloc: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - { - SCM vcell; - vcell = SCM_CAR (ptr) - 1L; - switch (SCM_CDR (vcell)) - { - default: - scm_gc_mark (vcell); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - case 1: /* ! */ - case 0: /* ! */ - { - SCM layout; - SCM * vtable_data; - int len; - char * fields_desc; - register SCM * mem; - register int x; - - vtable_data = (SCM *)vcell; - layout = vtable_data[scm_struct_i_layout]; - len = SCM_LENGTH (layout); - fields_desc = SCM_CHARS (layout); - /* We're using SCM_GCCDR here like STRUCT_DATA, except - that it removes the mark */ - mem = (SCM *)SCM_GCCDR (ptr); - - if (len) - { - for (x = 0; x < len - 2; x += 2, ++mem) - if (fields_desc[x] == 'p') - scm_gc_mark (*mem); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *mem; x; --x) - scm_gc_mark (*++mem); - else - scm_gc_mark (*mem); - } - } - if (!SCM_CDR (vcell)) - { - SCM_SETGCMARK (vcell); - ptr = vtable_data[scm_struct_i_vtable]; - goto gc_mark_loop; - } - } - } - } - break; - case scm_tcs_closures: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) - { - ptr = SCM_CLOSCAR (ptr); - goto gc_mark_nimp; - } - scm_gc_mark (SCM_CLOSCAR (ptr)); - ptr = SCM_GCCDR (ptr); - goto gc_mark_nimp; - case scm_tc7_vector: - case scm_tc7_lvector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); - i = SCM_LENGTH (ptr); - if (i == 0) - break; - while (--i > 0) - if (SCM_NIMP (SCM_VELTS (ptr)[i])) - scm_gc_mark (SCM_VELTS (ptr)[i]); - ptr = SCM_VELTS (ptr)[0]; - goto gc_mark_loop; - case scm_tc7_contin: - if SCM_GC8MARKP - (ptr) break; - SCM_SETGC8MARK (ptr); - scm_mark_locations (SCM_VELTS (ptr), - (scm_sizet) - (SCM_LENGTH (ptr) + - (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) / - sizeof (SCM_STACKITEM))); - break; - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_ivect: - case scm_tc7_uvect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - - case scm_tc7_string: - case scm_tc7_mb_string: - SCM_SETGC8MARK (ptr); - break; - - case scm_tc7_substring: - case scm_tc7_mb_substring: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - ptr = SCM_CDR (ptr); - goto gc_mark_loop; - - case scm_tc7_wvect: - if (SCM_GC8MARKP(ptr)) - break; - scm_weak_vectors[scm_n_weak++] = ptr; - if (scm_n_weak >= scm_weak_size) - { - SCM_SYSCALL (scm_weak_vectors = - (SCM *) realloc ((char *) scm_weak_vectors, - sizeof (SCM *) * (scm_weak_size *= 2))); - if (scm_weak_vectors == NULL) - { - scm_gen_puts (scm_regular_string, - "weak vector table", - scm_cur_errp); - scm_gen_puts (scm_regular_string, - "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n", - scm_cur_errp); - exit(SCM_EXIT_FAILURE); - } - } - SCM_SETGC8MARK (ptr); - if (SCM_IS_WHVEC_ANY (ptr)) - { - int x; - int len; - int weak_keys; - int weak_values; - - len = SCM_LENGTH (ptr); - weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); - weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); - - for (x = 0; x < len; ++x) - { - SCM alist; - alist = SCM_VELTS (ptr)[x]; - /* mark everything on the alist - * except the keys or values, according to weak_values and weak_keys. - */ - while ( SCM_NIMP (alist) - && SCM_CONSP (alist) - && !SCM_GCMARKP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM kvpair; - SCM next_alist; - - kvpair = SCM_CAR (alist); - next_alist = SCM_CDR (alist); - /* - * Do not do this: - * SCM_SETGCMARK (alist); - * SCM_SETGCMARK (kvpair); - * - * It may be that either the key or value is protected by - * an escaped reference to part of the spine of this alist. - * If we mark the spine here, and only mark one or neither of the - * key and value, they may never be properly marked. - * This leads to a horrible situation in which an alist containing - * freelist cells is exported. - * - * So only mark the spines of these arrays last of all marking. - * If somebody confuses us by constructing a weak vector - * with a circular alist then we are hosed, but at least we - * won't prematurely drop table entries. - */ - if (!weak_keys) - scm_gc_mark (SCM_CAR (kvpair)); - if (!weak_values) - scm_gc_mark (SCM_GCCDR (kvpair)); - alist = next_alist; - } - if (SCM_NIMP (alist)) - scm_gc_mark (alist); - } - } - break; - - case scm_tc7_msymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - scm_gc_mark (SCM_SYMBOL_FUNC (ptr)); - ptr = SCM_SYMBOL_PROPS (ptr); - goto gc_mark_loop; - case scm_tc7_ssymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - break; - case scm_tcs_subrs: - ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8)); - goto gc_mark_loop; - case scm_tc7_port: - i = SCM_PTOBNUM (ptr); - if (!(i < scm_numptob)) - goto def; - if (SCM_GC8MARKP (ptr)) - break; - if (SCM_PTAB_ENTRY(ptr)) - scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); - ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; - break; - case scm_tc7_smob: - if (SCM_GC8MARKP (ptr)) - break; - switch SCM_TYP16 (ptr) - { /* should be faster than going through scm_smobs */ - case scm_tc_free_cell: - /* printf("found free_cell %X ", ptr); fflush(stdout); */ - SCM_SETGC8MARK (ptr); - SCM_SETCDR (ptr, SCM_EOL); - break; - case scm_tcs_bignums: - case scm_tc16_flo: - SCM_SETGC8MARK (ptr); - break; - default: - i = SCM_SMOBNUM (ptr); - if (!(i < scm_numsmob)) - goto def; - ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; - } - break; - default: - def:scm_wta (ptr, "unknown type in ", "gc_mark"); - } -} - - -/* Mark a Region Conservatively - */ - -void -scm_mark_locations (x, n) - SCM_STACKITEM x[]; - scm_sizet n; -{ - register long m = n; - register int i, j; - register SCM_CELLPTR ptr; - - while (0 <= --m) - if SCM_CELLP (*(SCM **) & x[m]) - { - ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m])); - i = 0; - j = scm_n_heap_segs - 1; - if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - int seg_id; - seg_id = -1; - if ( (i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - int k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - if ( !scm_heap_table[seg_id].valid - || scm_heap_table[seg_id].valid (ptr, - &scm_heap_table[seg_id])) - scm_gc_mark (*(SCM *) & x[m]); - break; - } - - } - } -} - - -/* The following is a C predicate which determines if an SCM value can be - regarded as a pointer to a cell on the heap. The code is duplicated - from scm_mark_locations. */ - - -int -scm_cellp (value) - SCM value; -{ - register int i, j; - register SCM_CELLPTR ptr; - - if SCM_CELLP (*(SCM **) & value) - { - ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); - i = 0; - j = scm_n_heap_segs - 1; - if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - int seg_id; - seg_id = -1; - if ( (i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - int k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - if ( !scm_heap_table[seg_id].valid - || scm_heap_table[seg_id].valid (ptr, - &scm_heap_table[seg_id])) - return 1; - break; - } - - } - } - return 0; -} - - -static void -scm_mark_weak_vector_spines () -{ - int i; - - for (i = 0; i < scm_n_weak; ++i) - { - if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) - { - SCM *ptr; - SCM obj; - int j; - int n; - - obj = scm_weak_vectors[i]; - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - { - SCM alist; - - alist = ptr[j]; - while ( SCM_NIMP (alist) - && SCM_CONSP (alist) - && !SCM_GCMARKP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM_SETGCMARK (alist); - SCM_SETGCMARK (SCM_CAR (alist)); - alist = SCM_GCCDR (alist); - } - } - } - } -} - - - -void -scm_gc_sweep () -{ - register SCM_CELLPTR ptr; -#ifdef SCM_POINTERS_MUNGED - register SCM scmptr; -#else -#undef scmptr -#define scmptr (SCM)ptr -#endif - register SCM nfreelist; - register SCM *hp_freelist; - register long n; - register long m; - register scm_sizet j; - register int span; - scm_sizet i; - scm_sizet seg_size; - - n = 0; - m = 0; - - /* Reset all free list pointers. We'll reconstruct them completely - while scanning. */ - for (i = 0; i < scm_n_heap_segs; i++) - *scm_heap_table[i].freelistp = SCM_EOL; - - for (i = 0; i < scm_n_heap_segs; i++) - { - /* Unmarked cells go onto the front of the freelist this heap - segment points to. Rather than updating the real freelist - pointer as we go along, we accumulate the new head in - nfreelist. Then, if it turns out that the entire segment is - free, we free (i.e., malloc's free) the whole segment, and - simply don't assign nfreelist back into the real freelist. */ - hp_freelist = scm_heap_table[i].freelistp; - nfreelist = *hp_freelist; - - span = scm_heap_table[i].ncells; - ptr = CELL_UP (scm_heap_table[i].bounds[0]); - seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr; - for (j = seg_size + span; j -= span; ptr += span) - { -#ifdef SCM_POINTERS_MUNGED - scmptr = PTR2SCM (ptr); -#endif - switch SCM_TYP7 (scmptr) - { - case scm_tcs_cons_gloc: - if (SCM_GCMARKP (scmptr)) - { - if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1) - SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0); - goto cmrkcontinue; - } - { - SCM vcell; - vcell = SCM_CAR (scmptr) - 1L; - - if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) - { - SCM *p = (SCM *) SCM_GCCDR (scmptr); - m += p[scm_struct_i_n_words] * sizeof (SCM); - /* I feel like I'm programming in BCPL here... */ - free ((char *) p[scm_struct_i_ptr]); - } - } - break; - case scm_tcs_cons_imcar: - case scm_tcs_cons_nimcar: - case scm_tcs_closures: - if (SCM_GCMARKP (scmptr)) - goto cmrkcontinue; - break; - case scm_tc7_wvect: - if (SCM_GC8MARKP (scmptr)) - { - goto c8mrkcontinue; - } - else - { - m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free ((char *)(SCM_VELTS (scmptr) - 1)); - break; - } - - case scm_tc7_vector: - case scm_tc7_lvector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); - freechars: - scm_must_free (SCM_CHARS (scmptr)); - /* SCM_SETCHARS(scmptr, 0);*/ - break; - case scm_tc7_bvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - goto freechars; - case scm_tc7_byvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (char); - goto freechars; - case scm_tc7_ivect: - case scm_tc7_uvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long); - goto freechars; - case scm_tc7_svect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (short); - goto freechars; -#ifdef LONGLONGS - case scm_tc7_llvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long); - goto freechars; -#endif - case scm_tc7_fvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (float); - goto freechars; - case scm_tc7_dvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (double); - goto freechars; - case scm_tc7_cvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); - goto freechars; - case scm_tc7_substring: - case scm_tc7_mb_substring: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - break; - case scm_tc7_string: - case scm_tc7_mb_string: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) + 1; - goto freechars; - case scm_tc7_msymbol: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += ( SCM_LENGTH (scmptr) - + 1 - + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr))); - scm_must_free ((char *)SCM_SLOTS (scmptr)); - break; - case scm_tc7_contin: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); - goto freechars; - case scm_tc7_ssymbol: - if SCM_GC8MARKP(scmptr) - goto c8mrkcontinue; - break; - case scm_tcs_subrs: - continue; - case scm_tc7_port: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - if SCM_OPENP (scmptr) - { - int k = SCM_PTOBNUM (scmptr); - if (!(k < scm_numptob)) - goto sweeperr; - /* Keep "revealed" ports alive. */ - if (scm_revealed_count(scmptr) > 0) - continue; - /* Yes, I really do mean scm_ptobs[k].free */ - /* rather than ftobs[k].close. .close */ - /* is for explicit CLOSE-PORT by user */ - (scm_ptobs[k].free) (SCM_STREAM (scmptr)); - SCM_SETSTREAM (scmptr, 0); - scm_remove_from_port_table (scmptr); - scm_gc_ports_collected++; - SCM_SETAND_CAR (scmptr, ~SCM_OPN); - } - break; - case scm_tc7_smob: - switch SCM_GCTYP16 (scmptr) - { - case scm_tc_free_cell: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - break; -#ifdef SCM_BIGDIG - case scm_tcs_bignums: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - goto freechars; -#endif /* def SCM_BIGDIG */ - case scm_tc16_flo: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - switch ((int) (SCM_CAR (scmptr) >> 16)) - { - case (SCM_IMAG_PART | SCM_REAL_PART) >> 16: - m += sizeof (double); - case SCM_REAL_PART >> 16: - case SCM_IMAG_PART >> 16: - m += sizeof (double); - goto freechars; - case 0: - break; - default: - goto sweeperr; - } - break; - default: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - - { - int k; - k = SCM_SMOBNUM (scmptr); - if (!(k < scm_numsmob)) - goto sweeperr; - m += (scm_smobs[k].free) ((SCM) scmptr); - break; - } - } - break; - default: - sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep"); - } - n += span; -#if 0 - if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) - exit (2); -#endif - /* Stick the new cell on the front of nfreelist. */ - SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); - SCM_SETCDR (scmptr, nfreelist); - nfreelist = scmptr; - - continue; - c8mrkcontinue: - SCM_CLRGC8MARK (scmptr); - continue; - cmrkcontinue: - SCM_CLRGCMARK (scmptr); - } -#ifdef GC_FREE_SEGMENTS - if (n == seg_size) - { - scm_heap_size -= seg_size; - free ((char *) scm_heap_table[i].bounds[0]); - scm_heap_table[i].bounds[0] = 0; - for (j = i + 1; j < scm_n_heap_segs; j++) - scm_heap_table[j - 1] = scm_heap_table[j]; - scm_n_heap_segs -= 1; - i--; /* We need to scan the segment just moved. */ - } - else -#endif /* ifdef GC_FREE_SEGMENTS */ - /* Update the real freelist pointer to point to the head of - the list of free cells we've built for this segment. */ - *hp_freelist = nfreelist; - -#ifdef DEBUG_FREELIST - scm_check_freelist (); - scm_map_free_list (); -#endif - - scm_gc_cells_collected += n; - n = 0; - } - /* Scan weak vectors. */ - { - SCM *ptr; - for (i = 0; i < scm_n_weak; ++i) - { - if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) - { - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j])) - ptr[j] = SCM_BOOL_F; - } - else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ - { - SCM obj; - obj = scm_weak_vectors[i]; - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - { - SCM * fixup; - SCM alist; - int weak_keys; - int weak_values; - - weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); - weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); - - fixup = ptr + j; - alist = *fixup; - - while (SCM_NIMP (alist) - && SCM_CONSP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM key; - SCM value; - - key = SCM_CAAR (alist); - value = SCM_CDAR (alist); - if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key)) - || (weak_values && SCM_NIMP (value) && SCM_FREEP (value))) - { - *fixup = SCM_CDR (alist); - } - else - fixup = SCM_CDRLOC (alist); - alist = SCM_CDR (alist); - } - } - } - } - } - scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected); - scm_mallocated -= m; - scm_gc_malloc_collected = m; -} - - - - -/* {Front end to malloc} - * - * scm_must_malloc, scm_must_realloc, scm_must_free - * - * These functions provide services comperable to malloc, realloc, and - * free. They are for allocating malloced parts of scheme objects. - * The primary purpose of the front end is to impose calls to gc. - */ - -/* scm_must_malloc - * Return newly malloced storage or throw an error. - * - * The parameter WHAT is a string for error reporting. - * If the threshold scm_mtrigger will be passed by this - * allocation, or if the first call to malloc fails, - * garbage collect -- on the presumption that some objects - * using malloced storage may be collected. - * - * The limit scm_mtrigger may be raised by this allocation. - */ -char * -scm_must_malloc (len, what) - long len; - char *what; -{ - char *ptr; - scm_sizet size = len; - long nm = scm_mallocated + size; - if (len != size) - malerr: - scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); - if ((nm <= scm_mtrigger)) - { - SCM_SYSCALL (ptr = (char *) malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - return ptr; - } - } - - scm_igc (what); - nm = scm_mallocated + size; - SCM_SYSCALL (ptr = (char *) malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - return ptr; - } - goto malerr; -} - - -/* scm_must_realloc - * is similar to scm_must_malloc. - */ -char * -scm_must_realloc (where, olen, len, what) - char *where; - long olen; - long len; - char *what; -{ - char *ptr; - scm_sizet size = len; - long nm = scm_mallocated + size - olen; - if (len != size) - ralerr: - scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); - if ((nm <= scm_mtrigger)) - { - SCM_SYSCALL (ptr = (char *) realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - return ptr; - } - } - scm_igc (what); - nm = scm_mallocated + size - olen; - SCM_SYSCALL (ptr = (char *) realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - return ptr; - } - goto ralerr; -} - -void -scm_must_free (obj) - char *obj; -{ - if (obj) - free (obj); - else - scm_wta (SCM_INUM0, "already free", ""); -} - - - - -/* {Heap Segments} - * - * Each heap segment is an array of objects of a particular size. - * Every segment has an associated (possibly shared) freelist. - * A table of segment records is kept that records the upper and - * lower extents of the segment; this is used during the conservative - * phase of gc to identify probably gc roots (because they point - * into valid segments at reasonable offsets). - */ - -/* scm_expmem - * is true if the first segment was smaller than INIT_HEAP_SEG. - * If scm_expmem is set to one, subsequent segment allocations will - * allocate segments of size SCM_EXPHEAP(scm_heap_size). - */ -int scm_expmem = 0; - -/* scm_heap_org - * is the lowest base address of any heap segment. - */ -SCM_CELLPTR scm_heap_org; - -struct scm_heap_seg_data * scm_heap_table = 0; -int scm_n_heap_segs = 0; - -/* scm_heap_size - * is the total number of cells in heap segments. - */ -long scm_heap_size = 0; - -/* init_heap_seg - * initializes a new heap segment and return the number of objects it contains. - * - * The segment origin, segment size in bytes, and the span of objects - * in cells are input parameters. The freelist is both input and output. - * - * This function presume that the scm_heap_table has already been expanded - * to accomodate a new segment record. - */ - - -static scm_sizet -init_heap_seg (seg_org, size, ncells, freelistp) - SCM_CELLPTR seg_org; - scm_sizet size; - int ncells; - SCM *freelistp; -{ - register SCM_CELLPTR ptr; -#ifdef SCM_POINTERS_MUNGED - register SCM scmptr; -#else -#undef scmptr -#define scmptr ptr -#endif - SCM_CELLPTR seg_end; - scm_sizet new_seg_index; - scm_sizet n_new_objects; - - if (seg_org == NULL) - return 0; - - ptr = seg_org; - - /* Compute the ceiling on valid object pointers w/in this segment. - */ - seg_end = CELL_DN ((char *) ptr + size); - - /* Find the right place and insert the segment record. - * - */ - for (new_seg_index = 0; - ( (new_seg_index < scm_n_heap_segs) - && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)); - new_seg_index++) - ; - - { - int i; - for (i = scm_n_heap_segs; i > new_seg_index; --i) - scm_heap_table[i] = scm_heap_table[i - 1]; - } - - ++scm_n_heap_segs; - - scm_heap_table[new_seg_index].valid = 0; - scm_heap_table[new_seg_index].ncells = ncells; - scm_heap_table[new_seg_index].freelistp = freelistp; - scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr; - scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end; - - - /* Compute the least valid object pointer w/in this segment - */ - ptr = CELL_UP (ptr); - - - n_new_objects = seg_end - ptr; - - /* Prepend objects in this segment to the freelist. - */ - while (ptr < seg_end) - { -#ifdef SCM_POINTERS_MUNGED - scmptr = PTR2SCM (ptr); -#endif - SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells)); - ptr += ncells; - } - - ptr -= ncells; - - /* Patch up the last freelist pointer in the segment - * to join it to the input freelist. - */ - SCM_SETCDR (PTR2SCM (ptr), *freelistp); - *freelistp = PTR2SCM (CELL_UP (seg_org)); - - scm_heap_size += (ncells * n_new_objects); - return size; -#ifdef scmptr -#undef scmptr -#endif -} - - -static void -alloc_some_heap (ncells, freelistp) - int ncells; - SCM * freelistp; -{ - struct scm_heap_seg_data * tmptable; - SCM_CELLPTR ptr; - scm_sizet len; - - /* Critical code sections (such as the garbage collector) - * aren't supposed to add heap segments. - */ - if (scm_gc_heap_lock) - scm_wta (SCM_UNDEFINED, "need larger initial", "heap"); - - /* Expand the heap tables to have room for the new segment. - * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg - * only if the allocation of the segment itself succeeds. - */ - len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data); - - SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *) - realloc ((char *)scm_heap_table, len))); - if (!tmptable) - scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); - else - scm_heap_table = tmptable; - - - /* Pick a size for the new heap segment. - * The rule for picking the size of a segment is explained in - * gc.h - */ - if (scm_expmem) - { - len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)); - if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len) - len = 0; - } - else - len = SCM_HEAP_SEG_SIZE; - - { - scm_sizet smallest; - - smallest = (ncells * sizeof (scm_cell)); - if (len < smallest) - len = (ncells * sizeof (scm_cell)); - - /* Allocate with decaying ambition. */ - while ((len >= SCM_MIN_HEAP_SEG_SIZE) - && (len >= smallest)) - { - SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len)); - if (ptr) - { - init_heap_seg (ptr, len, ncells, freelistp); - return; - } - len /= 2; - } - } - - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); -} - - - -SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name); -SCM -scm_unhash_name (name) - SCM name; -{ - int x; - int bound; - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name); - SCM_DEFER_INTS; - bound = scm_n_heap_segs; - for (x = 0; x < bound; ++x) - { - SCM_CELLPTR p; - SCM_CELLPTR pbound; - p = (SCM_CELLPTR)scm_heap_table[x].bounds[0]; - pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1]; - while (p < pbound) - { - SCM incar; - incar = p->car; - if (1 == (7 & (int)incar)) - { - --incar; - if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name)) - && (SCM_CDR (incar) != 0) - && (SCM_CDR (incar) != 1)) - { - p->car = name; - } - } - ++p; - } - } - SCM_ALLOW_INTS; - return name; -} - - - -/* {GC Protection Helper Functions} - */ - - -void -scm_remember (ptr) - SCM * ptr; -{} - - -#ifdef __STDC__ -SCM -scm_return_first (SCM elt, ...) -#else -SCM -scm_return_first (elt, va_alist) - SCM elt; - va_dcl -#endif -{ - return elt; -} - - -SCM -scm_permanent_object (obj) - SCM obj; -{ - SCM_REDEFER_INTS; - scm_permobjs = scm_cons (obj, scm_permobjs); - SCM_REALLOW_INTS; - return obj; -} - - - -int -scm_init_storage (init_heap_size) - long init_heap_size; -{ - scm_sizet j; - - j = SCM_NUM_PROTECTS; - while (j) - scm_sys_protects[--j] = SCM_BOOL_F; - scm_block_gc = 1; - scm_freelist = SCM_EOL; - scm_expmem = 0; - - j = SCM_HEAP_SEG_SIZE; - scm_mtrigger = SCM_INIT_MALLOC_LIMIT; - scm_heap_table = ((struct scm_heap_seg_data *) - scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims")); - if (0L == init_heap_size) - init_heap_size = SCM_INIT_HEAP_SIZE; - j = init_heap_size; - if ((init_heap_size != j) - || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) - { - j = SCM_HEAP_SEG_SIZE; - if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) - return 1; - } - else - scm_expmem = 1; - scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]); - /* scm_hplims[0] can change. do not remove scm_heap_org */ - if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *)))) - return 1; - - /* Initialise the list of ports. */ - scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table) - * scm_port_table_room)); - if (!scm_port_table) - return 1; - - - scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); - SCM_SETCDR (scm_undefineds, scm_undefineds); - - scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_nullstr = scm_makstr (0L, 0); - scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED); - scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); - scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim)); - scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); - scm_stand_in_procs = SCM_EOL; - scm_permobjs = SCM_EOL; - scm_asyncs = SCM_EOL; - scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); -#ifdef SCM_BIGDIG - scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); -#endif - return 0; -} - - -void -scm_init_gc () -{ -#include "gc.x" -} diff --git a/libguile/gc.h b/libguile/gc.h deleted file mode 100644 index 0a1f20549..000000000 --- a/libguile/gc.h +++ /dev/null @@ -1,101 +0,0 @@ -/* classes: h_files */ - -#ifndef GCH -#define GCH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -#define SCM_FREEP(x) (SCM_CAR(x)==scm_tc_free_cell) -#define SCM_NFREEP(x) (!SCM_FREEP(x)) - -extern struct scm_heap_seg_data *scm_heap_table; -extern int scm_n_heap_segs; -extern int scm_take_stdin; -extern int scm_block_gc; -extern int scm_gc_heap_lock; - - - -extern long scm_heap_size; -extern SCM_CELLPTR scm_heap_org; -extern SCM scm_freelist; -extern unsigned long scm_gc_cells_collected; -extern unsigned long scm_gc_malloc_collected; -extern unsigned long scm_gc_ports_collected; -extern unsigned long scm_cells_allocated; -extern unsigned long scm_mallocated; -extern long scm_mtrigger; - -#ifdef DEBUG_FREELIST -extern void scm_debug_newcell SCM_P ((SCM *into)); -#endif - - - -extern SCM scm_object_addr SCM_P ((SCM obj)); -extern SCM scm_unhash_name SCM_P ((SCM name)); -extern SCM scm_gc_stats SCM_P ((void)); -extern void scm_gc_start SCM_P ((char *what)); -extern void scm_gc_end SCM_P ((void)); -extern SCM scm_gc SCM_P ((void)); -extern void scm_gc_for_alloc SCM_P ((int ncells, SCM * freelistp)); -extern SCM scm_gc_for_newcell SCM_P ((void)); -extern void scm_igc SCM_P ((char *what)); -extern void scm_gc_mark SCM_P ((SCM p)); -extern void scm_mark_locations SCM_P ((SCM_STACKITEM x[], scm_sizet n)); -extern int scm_cellp SCM_P ((SCM value)); -extern void scm_gc_sweep SCM_P ((void)); -extern char * scm_must_malloc SCM_P ((long len, char *what)); -extern char * scm_must_realloc SCM_P ((char *where, long olen, long len, - char *what)); -extern void scm_must_free SCM_P ((char *obj)); -extern void scm_remember SCM_P ((SCM * ptr)); -extern SCM scm_return_first SCM_P ((SCM elt, ...)); -extern SCM scm_permanent_object SCM_P ((SCM obj)); -extern SCM scm_protect_object SCM_P ((SCM obj)); -extern SCM scm_unprotect_object SCM_P ((SCM obj)); -extern int scm_init_storage SCM_P ((long init_heap_size)); -extern void scm_init_gc SCM_P ((void)); -#endif /* GCH */ diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h deleted file mode 100644 index dd8aac3d9..000000000 --- a/libguile/gdb_interface.h +++ /dev/null @@ -1,127 +0,0 @@ -/* Simple interpreter interface for GDB, the GNU debugger. - Copyright (C) 1996 Mikael Djurfeldt. - -This file is part of GDB. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -The author can be reached at djurfeldt@nada.kth.se -Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ - -#ifndef GDB_INTERFACE_H -#define GDB_INTERFACE_H - -/* This is the header file for GDB's interpreter interface. The - interpreter must supply definitions of all symbols declared in this - file. - - Before including this file, you must #define GDB_TYPE to be the - data type used for communication with the interpreter. */ - -/* The following macro can be used to anchor the symbols of the - interface in your main program. This is necessary if the interface - is defined in a library, such as Guile. */ - -#define GDB_INTERFACE \ -void *gdb_interface[] = { \ - &gdb_options, \ - &gdb_language, \ - &gdb_result, \ - &gdb_output, \ - &gdb_output_length, \ - gdb_maybe_valid_type_p, \ - gdb_read, \ - gdb_eval, \ - gdb_print, \ - gdb_binding \ -}; \ - - -/* GDB_OPTIONS is a set of flags informing gdb what features are present - in the interface. Currently only one option is supported: */ - -/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new - top level bindings on demand (through gdb_top_level_binding) */ - -#define GDB_HAVE_BINDINGS 1 - -extern unsigned short gdb_options; - -/* GDB_LANGUAGE holds the name of the preferred language mode for this - interpreter. For lisp interpreters, the suggested mode is "lisp/c". */ - -extern char *gdb_language; - -/* GDB_RESULT is used for passing results from the interpreter to GDB */ - -extern GDB_TYPE gdb_result; - -/* The interpreter passes strings to GDB in GDB_OUTPUT and - GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the - string. GDB_OUTPUT_LENGTH should hold its length. The string - doesn't need to be terminated by '\0'. */ - -extern char *gdb_output; - -extern int gdb_output_length; - -/* Return TRUE if the interpreter regards VALUE's type as valid. A - lazy implementation is allowed to pass TRUE always. FALSE should - only be returned when it is certain that VALUE is not valid. - - In the "lisp/c" language mode, this is used to heuristically - discriminate lisp values from C values during printing. */ - -extern int gdb_maybe_valid_type_p SCM_P ((GDB_TYPE value)); - -/* Parse expression in string STR. Store result in GDB_RESULT, then - return 0 to indicate success. On error, return -1 to indicate - failure. An error string can be passed in GDB_OUTPUT and - GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if - no message is passed. Please note that the resulting value should - be protected against garbage collection. */ - -extern int gdb_read SCM_P ((char *str)); - -/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0 - to indicate success. On error, return -1 to indicate failure. Any - output (both on success and failure) can be passed in GDB_OUTPUT - and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero - if no output is passed. Please note that the resulting lisp object - should be protected against garbage collection. */ - -extern int gdb_eval SCM_P ((GDB_TYPE exp)); - -/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH. - Return 0 to indicate success. On error, return -1 to indicate - failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on - failure. Note that this function should be robust against strange - values. It could in fact be passed any kind of value. */ - -extern int gdb_print SCM_P ((GDB_TYPE value)); - -/* Bind NAME to VALUE in interpreter. (GDB has previously obtained - NAME by passing a string to gdb_read.) Return 0 to indicate - success or -1 to indicate failure. This feature is optional. GDB - will only call this function if the GDB_HAVE_BINDINGS flag is set - in gdb_options. Note that GDB may call this function many times - for the same name. - - For scheme interpreters, this function should introduce top-level - bindings. */ - -extern int gdb_binding SCM_P ((GDB_TYPE name, GDB_TYPE value)); - -#endif /* GDB_INTERFACE_H */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c deleted file mode 100644 index 3ce4f2eca..000000000 --- a/libguile/gdbint.c +++ /dev/null @@ -1,325 +0,0 @@ -/* GDB interface for Guile - * Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - -#include <stdio.h> -#include "_scm.h" -#include "tag.h" -#include "strports.h" -#include "read.h" -#include "eval.h" -#include "chars.h" - -#include "gdbint.h" - -/* {Support for debugging with gdb} - * - * TODO: - * - * 1. Redirect outputs - * 2. Catch errors - * 3. Prevent print from causing segmentation fault when given broken pairs - */ - -#include <stdio.h> -#include "_scm.h" - -#define GDB_TYPE SCM - -#include "gdb_interface.h" - - - -/* Be carefull when this macro is true. - scm_gc_heap_lock is set during gc. - */ -#define SCM_GC_P (scm_gc_heap_lock) - -/* Macros that encapsulate blocks of code which can be called by the - * debugger. - */ -#define SCM_BEGIN_FOREIGN_BLOCK \ -{ \ - old_ints = scm_ints_disabled; scm_ints_disabled = 1; \ - old_gc = scm_block_gc; scm_block_gc = 1; \ - scm_print_carefully_p = 1; \ -} \ - - -#define SCM_END_FOREIGN_BLOCK \ -{ \ - scm_print_carefully_p = 0; \ - scm_block_gc = old_gc; \ - scm_ints_disabled = old_ints; \ -} \ - - -#define RESET_STRING { gdb_output_length = 0; } - -#define SEND_STRING(str) \ -{ \ - gdb_output = str; \ - gdb_output_length = strlen (str); \ -} \ - - -/* {Gdb interface} - */ - -unsigned short gdb_options = GDB_HAVE_BINDINGS; - -char *gdb_language = "lisp/c"; - -SCM gdb_result; - -char *gdb_output; - -int gdb_output_length; - -int scm_print_carefully_p; - -static SCM gdb_input_port; -static int port_mark_p, stream_mark_p, string_mark_p; - -static SCM tok_buf; -static int tok_buf_mark_p; - -static SCM gdb_output_port; -static int old_ints, old_gc; - - -static void unmark_port SCM_P ((SCM port)); - -static void -unmark_port (port) - SCM port; -{ - SCM stream, string; - port_mark_p = SCM_GC8MARKP (port); - SCM_CLRGC8MARK (port); - stream = SCM_STREAM (port); - stream_mark_p = SCM_GCMARKP (stream); - SCM_CLRGCMARK (stream); - string = SCM_CDR (stream); - string_mark_p = SCM_GC8MARKP (string); - SCM_CLRGC8MARK (string); -} - - -static void remark_port SCM_P ((SCM port)); - -static void -remark_port (port) - SCM port; -{ - SCM stream = SCM_STREAM (port); - SCM string = SCM_CDR (stream); - if (string_mark_p) SCM_SETGC8MARK (string); - if (stream_mark_p) SCM_SETGCMARK (stream); - if (port_mark_p) SCM_SETGC8MARK (port); -} - - -int -gdb_maybe_valid_type_p (value) - SCM value; -{ - if (SCM_IMP (value) || scm_cellp (value)) - return scm_tag (value) != SCM_MAKINUM (-1); - return 0; -} - - -int -gdb_read (str) - char *str; -{ - SCM ans; - int status = 0; - RESET_STRING; - /* Need to be restrictive about what to read? */ - if (SCM_GC_P) - { - char *p; - for (p = str; *p != '\0'; ++p) - switch (*p) - { - case '(': - case '\'': - case '"': - SEND_STRING ("Can't read this kind of expressions during gc"); - return -1; - case '#': - if (*++p == '\0') - goto premature; - if (*p == '\\') - { - if (*++p != '\0') - continue; - premature: - SEND_STRING ("Premature end of lisp expression"); - return -1; - } - default: - continue; - } - } - SCM_BEGIN_FOREIGN_BLOCK; - unmark_port (gdb_input_port); - /* Replace string in input port and reset stream */ - ans = SCM_CDR (SCM_STREAM (gdb_input_port)); - SCM_SETCHARS (ans, str); - SCM_SETLENGTH (ans, strlen (str), scm_tc7_string); - SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0); - /* Read one object */ - tok_buf_mark_p = SCM_GC8MARKP (tok_buf); - SCM_CLRGC8MARK (tok_buf); - ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &ans); - if (SCM_GC_P) - { - if (SCM_NIMP (ans)) - { - SEND_STRING ("Non-immediate created during gc. Memory may be trashed."); - status = -1; - goto exit; - } - } - gdb_result = ans; - /* Protect answer from future GC */ - if (SCM_NIMP (ans)) - scm_permanent_object (ans); -exit: - if (tok_buf_mark_p) - SCM_SETGC8MARK (tok_buf); - remark_port (gdb_input_port); - SCM_END_FOREIGN_BLOCK; - return status; -} - - -int -gdb_eval (exp) - SCM exp; -{ - RESET_STRING; - if (SCM_IMP (exp)) - { - gdb_result = exp; - return 0; - } - if (SCM_GC_P) - { - SEND_STRING ("Can't evaluate lisp expressions during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); - gdb_result = scm_permanent_object (scm_ceval (exp, env)); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - - -int -gdb_print (obj) - SCM obj; -{ - RESET_STRING; - SCM_BEGIN_FOREIGN_BLOCK; - /* Reset stream */ - SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0); - scm_write (obj, gdb_output_port); - scm_display (SCM_MAKICHR (0), gdb_output_port); - SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port)))); - SCM_END_FOREIGN_BLOCK; - return 0; -} - - -int -gdb_binding (name, value) - SCM name; - SCM value; -{ - RESET_STRING; - if (SCM_GC_P) - { - SEND_STRING ("Can't create new bindings during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - SCM vcell = scm_sym2vcell (name, - SCM_CDR (scm_top_level_lookup_closure_var), - SCM_BOOL_T); - SCM_SETCDR (vcell, value); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - -void -scm_init_gdbint () -{ - static char *s = "scm_init_gdb_interface"; - SCM port; - - scm_print_carefully_p = 0; - - port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s); - gdb_output_port = scm_permanent_object (port); - - port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED), - SCM_OPN | SCM_RDNG, - s); - gdb_input_port = scm_permanent_object (port); - - tok_buf = scm_permanent_object (scm_makstr (30L, 0)); -} diff --git a/libguile/gdbint.h b/libguile/gdbint.h deleted file mode 100644 index bf12524f6..000000000 --- a/libguile/gdbint.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef GDBINTH -#define GDBINTH -/* Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -extern int scm_print_carefully_p; - -extern void scm_init_gdbint SCM_P ((void)); - -#endif /* GDBINTH */ diff --git a/libguile/genio.c b/libguile/genio.c deleted file mode 100644 index 5ebd86e3f..000000000 --- a/libguile/genio.c +++ /dev/null @@ -1,508 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "genio.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - - -static void scm_putc SCM_P ((int c, SCM port)); - -static void -scm_putc (c, port) - int c; - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port))); -} - - - -static void scm_puts SCM_P ((char *s, SCM port)); - -static void -scm_puts (s, port) - char *s; - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fputs) (s, SCM_STREAM (port))); -#ifdef TRANSCRIPT_SUPPORT - if (scm_trans && (port == def_outp || port == cur_errp)) - SCM_SYSCALL (fputs (s, scm_trans)); -#endif -} - - - -static int scm_lfwrite SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM port)); - -static int -scm_lfwrite (ptr, size, nitems, port) - char *ptr; - scm_sizet size; - scm_sizet nitems; - SCM port; -{ - int ret; - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, SCM_STREAM (port)))); -#ifdef TRANSCRIPT_SUPPORT - if (scm_trans && (port == def_outp || port == cur_errp)) - SCM_SYSCALL (fwrite (ptr, size, nitems, scm_trans)); -#endif - return ret; -} - - - - - -void -scm_gen_putc (c, port) - int c; - SCM port; -{ - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - { - /* Nothing good to do with extended chars here... - * just truncate them. - */ - scm_putc ((unsigned char)c, port); - break; - } - - case scm_mb_port: - { - char buf[256]; - int len; - - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_MAKICHR (c), - "huge translation", "scm_gen_putc"); - - len = xwctomb (buf, c); - - SCM_ASSERT ((len >= 0), SCM_MAKICHR (c), "bogus character", "scm_gen_putc"); - - if (len == 0) - scm_putc (0, port); - else - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - break; - } - - case scm_wchar_port: - { - scm_putc (((unsigned char)(c >> 8) & 0xff), port); - scm_putc ((unsigned char)(c & 0xff), port); - break; - } - } -} - - - - - - -void -scm_gen_puts (rep, str_data, port) - enum scm_string_representation_type rep; - char *str_data; - SCM port; -{ - switch (rep) - { - - case scm_regular_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_puts (str_data, port); - return; - case scm_wchar_port: - { - while (*str_data) - { - scm_putc (0, port); - scm_putc (*str_data, port); - ++str_data; - } - return; - } - } - - case scm_mb_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_puts (str_data, port); - return; - case scm_wchar_port: - { - xwchar_t output; - int len; - int size; - - size = strlen (str_data); - while (size) - { - len = xmbtowc (&output, str_data, size); - SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts"); - scm_putc ((output >> 8) & 0xff, port); - scm_putc (output & 0xff, port); - size -= len; - str_data += len; - } - return; - } - } - - case scm_wchar_string: - { - xwchar_t * wstr_data; - - wstr_data = (xwchar_t *) str_data; - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - while (*wstr_data) - { - scm_putc ((unsigned char) *wstr_data, port); - ++wstr_data; - } - return; - - case scm_mb_port: - { - char buf[256]; - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - while (*wstr_data) - { - int len; - - len = xwctomb (buf, *wstr_data); - - SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts"); - - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - ++wstr_data; - } - return; - } - - case scm_wchar_port: - { - int len; - for (len = 0; wstr_data[len]; ++len) - ; - scm_lfwrite (str_data, sizeof (xwchar_t), len, port); - return; - } - } - } - } -} - - - - - -void -scm_gen_write (rep, str_data, nitems, port) - enum scm_string_representation_type rep; - char *str_data; - scm_sizet nitems; - SCM port; -{ - /* is nitems bytes or characters in the mb_string case? */ - - switch (rep) - { - case scm_regular_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_lfwrite (str_data, 1, nitems, port); - return; - case scm_wchar_port: - { - while (nitems) - { - scm_putc (0, port); - scm_putc (*str_data, port); - ++str_data; - --nitems; - } - return; - } - } - - case scm_mb_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_lfwrite (str_data, 1, nitems, port); - return; - - case scm_wchar_port: - { - xwchar_t output; - int len; - - while (nitems) - { - len = xmbtowc (&output, str_data, nitems); - SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts"); - scm_putc ((output >> 8) & 0xff, port); - scm_putc (output & 0xff, port); - nitems -= len; - str_data += len; - } - return; - } - } - - case scm_wchar_string: - { - xwchar_t * wstr_data; - - wstr_data = (xwchar_t *) str_data; - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - while (nitems) - { - scm_putc ((unsigned char) *wstr_data, port); - ++wstr_data; - --nitems; - } - return; - - case scm_mb_port: - { - char buf[256]; - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - while (nitems) - { - int len; - - len = xwctomb (buf, *wstr_data); - - SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts"); - - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - ++wstr_data; - --nitems; - } - return; - } - - case scm_wchar_port: - { - scm_lfwrite (str_data, sizeof (xwchar_t), nitems, port); - return; - } - } - } - } -} - - - - - -static int scm_getc SCM_P ((SCM port)); - -static int -scm_getc (port) - SCM port; -{ - SCM f; - int c; - scm_sizet i; - - f = SCM_STREAM (port); - i = SCM_PTOBNUM (port); - SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f)); - return c; -} - - -int -scm_gen_getc (port) - SCM port; -{ - int c; - - /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */ - if (SCM_CRDYP (port)) - { - c = SCM_CGETUN (port); - SCM_CLRDY (port); /* Clear ungetted char */ - - return_c: - if (c == '\n') - { - SCM_INCLINE (port); - } - else if (c == '\t') - { - SCM_TABCOL (port); - } - else - { - SCM_INCCOL (port); - } - return c; - } - - - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - c = scm_getc (port); - goto return_c; - - case scm_mb_port: - { - int x; - unsigned char buf[256]; - - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - x = 0; - while (1) - { - xwchar_t out; - c = scm_getc (port); - - if (c == EOF) - return EOF; - - buf[x] = c; - - if (xmbtowc (&out, buf, x + 1) > 0) - { - c = out; - goto return_c; - } - - SCM_ASSERT (x < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_getc"); - ++x; - } - } - - - case scm_wchar_port: - { - int hi; - int lo; - hi = scm_getc (port); - lo = (hi == EOF - ? EOF - : scm_getc (port)); - c = ((hi == EOF) - ? EOF - : ((hi << 8) | lo)); - goto return_c; - } - - - default: - return EOF; - } -} - - -void -scm_gen_ungetc (c, port) - int c; - SCM port; -{ -/* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_gen_ungetc");*/ - SCM_CUNGET (c, port); - if (c == '\n') - { - /* What should col be in this case? - * We'll leave it at -1. - */ - SCM_LINUM (port) -= 1; - } - else - SCM_COL(port) -= 1; -} - - diff --git a/libguile/genio.h b/libguile/genio.h deleted file mode 100644 index 78d17fac5..000000000 --- a/libguile/genio.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef GENIOH -#define GENIOH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern void scm_gen_putc SCM_P ((int c, SCM port)); -extern void scm_gen_puts SCM_P ((enum scm_string_representation_type rep, - char *str_data, - SCM port)); -extern void scm_gen_write SCM_P ((enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port)); -extern int scm_gen_getc SCM_P ((SCM port)); -extern void scm_gen_ungetc SCM_P ((int c, SCM port)); - -#endif /* GENIOH */ diff --git a/libguile/gscm.c b/libguile/gscm.c deleted file mode 100644 index daf172730..000000000 --- a/libguile/gscm.c +++ /dev/null @@ -1,594 +0,0 @@ -/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - - -#include <stdio.h> -#include <sys/param.h> -#include "gscm.h" -#include "_scm.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -extern char *getenv (); - - -/* {Top Level Evaluation} - * - * Top level evaluation has to establish a dynamic root context, - * enable Scheme signal handlers, and catch global escapes (errors, quits, - * aborts, restarts, and execs) from the interpreter. - */ - - -/* {Printing Objects to Strings} - */ - - -static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj)); - -static GSCM_status -gscm_portprint_obj (port, obj) - SCM port; - SCM obj; -{ - scm_prin1 (obj, port, 1); - return GSCM_OK; -} - - -struct seval_str_frame -{ - GSCM_status status; - SCM * answer; - GSCM_top_level top; - char * str; -}; - - -static void _seval_str_fn SCM_P ((void * vframe)); - -static void -_seval_str_fn (vframe) - void * vframe; -{ - struct seval_str_frame * frame; - frame = (struct seval_str_frame *)vframe; - frame->status = gscm_seval_str (frame->answer, frame->top, frame->str); -} - - - - -static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj)); - -static GSCM_status -gscm_strprint_obj (answer, obj) - SCM * answer; - SCM obj; -{ - SCM str; - SCM port; - GSCM_status stat; - str = scm_makstr (64, 0); - port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj"); - stat = gscm_portprint_obj (port, obj); - if (stat == GSCM_OK) - *answer = str; - else - *answer = SCM_BOOL_F; - return stat; -} - - -static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj)); - -static GSCM_status -gscm_cstr (answer, obj) - char ** answer; - SCM obj; -{ - GSCM_status stat; - - *answer = (char *)malloc (SCM_LENGTH (obj)); - stat = GSCM_OK; - if (!*answer) - stat = GSCM_OUT_OF_MEM; - else - memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj)); - return stat; -} - - -/* {Invoking The Interpreter} - */ - - -static SCM gscm_silent_repl SCM_P ((SCM env)); - -static SCM -gscm_silent_repl (env) - SCM env; -{ - SCM source; - SCM answer; - answer = SCM_UNSPECIFIED; - while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL) - answer = scm_eval_x (source); - return answer; -} - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - - -static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp)); - -static GSCM_status -_eval_port (answer, toplvl, port, printp) - SCM * answer; - GSCM_top_level toplvl; - SCM port; - int printp; -{ - SCM saved_inp; - GSCM_status status; - setjmp_type i; - static int deja_vu = 0; - SCM ignored; - - if (deja_vu) - return GSCM_ILLEGALLY_REENTERED; - - ++deja_vu; - /* Take over signal handlers for all the interesting signals. - */ - scm_init_signals (); - - - /* Default return values: - */ - if (!answer) - answer = &ignored; - status = GSCM_OK; - *answer = SCM_BOOL_F; - - /* Perform evalutation under a new dynamic root. - * - */ - SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; -#endif - saved_inp = scm_cur_inp; - i = setjmp (SCM_JMPBUF (scm_rootcont)); -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - if (!i) - { - scm_gc_heap_lock = 0; - scm_ints_disabled = 0; - /* need to close loading files here. */ - scm_cur_inp = port; - { - SCM top_env; - top_env = SCM_EOL; - *answer = gscm_silent_repl (top_env); - } - scm_cur_inp = saved_inp; - if (printp) - status = gscm_strprint_obj (answer, *answer); - } - else - { - scm_cur_inp = saved_inp; - *answer = scm_exitval; - if (printp) - gscm_strprint_obj (answer, *answer); - status = GSCM_ERROR; - } - - scm_gc_heap_lock = 1; - scm_ints_disabled = 1; - scm_restore_signals (); - --deja_vu; - return status; -} - - -static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); - -static GSCM_status -seval_str (answer, toplvl, str) - SCM *answer; - GSCM_top_level toplvl; - char * str; -{ - SCM scheme_str; - SCM port; - GSCM_status status; - - scheme_str = scm_makfromstr (str, strlen (str), 0); - port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str"); - status = _eval_port (answer, toplvl, port, 0); - return status; -} - - - -GSCM_status -gscm_seval_str (answer, toplvl, str) - SCM *answer; - GSCM_top_level toplvl; - char * str; -{ - SCM_STACKITEM i; - GSCM_status status; - scm_stack_base = &i; - status = seval_str (answer, toplvl, str); - scm_stack_base = 0; - return status; -} - - -void -format_load_command (buf, file_name) - char * buf; - char *file_name; -{ - char quoted_name[MAXPATHLEN + 1]; - int source; - int dest; - - for (source = dest = 0; file_name[source]; ++source) - { - if (file_name[source] == '"') - quoted_name[dest++] = '\\'; - quoted_name[dest++] = file_name[source]; - } - quoted_name[dest] = 0; - sprintf (buf, "(%%try-load \"%s\")", quoted_name); -} - - -GSCM_status -gscm_seval_file (answer, toplvl, file_name) - SCM *answer; - GSCM_top_level toplvl; - char * file_name; -{ - char command[MAXPATHLEN * 3]; - format_load_command (command, file_name); - return gscm_seval_str (answer, toplvl, command); -} - - - -static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); - -static GSCM_status -eval_str (answer, toplvl, str) - char ** answer; - GSCM_top_level toplvl; - char * str; -{ - SCM sanswer; - SCM scheme_str; - SCM port; - GSCM_status status; - - scheme_str = scm_makfromstr (str, strlen (str), 0); - port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str"); - status = _eval_port (&sanswer, toplvl, port, 1); - if (answer) - { - if (status == GSCM_OK) - status = gscm_cstr (answer, sanswer); - else - *answer = 0; - } - return status; -} - - - -GSCM_status -gscm_eval_str (answer, toplvl, str) - char ** answer; - GSCM_top_level toplvl; - char * str; -{ - SCM_STACKITEM i; - GSCM_status status; - scm_stack_base = &i; - status = eval_str (answer, toplvl, str); - scm_stack_base = 0; - return status; -} - - - -GSCM_status -gscm_eval_file (answer, toplvl, file_name) - char ** answer; - GSCM_top_level toplvl; - char * file_name; -{ - char command[MAXPATHLEN * 3]; - format_load_command (command, file_name); - return gscm_eval_str (answer, toplvl, command); -} - - - - -/* {Error Messages} - */ - - -#ifdef __GNUC__ -# define AT(X) [X] = -#else -# define AT(X) -#endif - -static char * gscm_error_msgs[] = -{ - AT(GSCM_OK) "No error.", - AT(GSCM_ERROR) "ERROR in init file.", - AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.", - AT(GSCM_OUT_OF_MEM) "Out of memory.", - AT(GSCM_ERROR_OPENING_FILE) "Error opening file.", - AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file." -}; - - -char * -gscm_error_msg (n) - int n; -{ - if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *)))) - return "Unrecognized error."; - else - return gscm_error_msgs[n]; -} - - - -/* {Defining New Procedures} - */ - - -SCM -gscm_make_subr (fn, req, opt, varp, doc) - SCM (*fn)(); - int req; - int opt; - int varp; - char * doc; -{ - return scm_make_gsubr ("*anonymous*", req, opt, varp, fn); -} - - -int -gscm_2_char (c) - SCM c; -{ - SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char"); - return SCM_ICHR (c); -} - - - - -void -gscm_2_str (out, len_out, objp) - char ** out; - int * len_out; - SCM * objp; -{ - SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str"); - if (out) - *out = SCM_CHARS (*objp); - if (len_out) - *len_out = SCM_LENGTH (*objp); -} - - - -void -gscm_error (message, args) - char * message; - SCM args; -{ - SCM errsym; - SCM str; - - errsym = SCM_CAR (scm_intern ("error", 5)); - str = scm_makfrom0str (message); - scm_throw (errsym, scm_cons (str, args)); -} - - - -GSCM_status -gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd) - int argc; - char ** argv; - FILE * in; - FILE * out; - FILE * err; - GSCM_status (*initfn)(); - char * initfile; - char * initcmd; -{ - SCM_STACKITEM i; - GSCM_status status; - GSCM_top_level top; - - scm_ports_prehistory (); - scm_smob_prehistory (); - scm_tables_prehistory (); - scm_init_storage (0); - scm_start_stack (&i, in, out, err); - scm_init_gsubr (); - scm_init_curry (); - scm_init_feature (); -/* scm_init_debug (); */ - scm_init_alist (); - scm_init_append (); - scm_init_arbiters (); - scm_init_async (); - scm_init_boolean (); - scm_init_chars (); - scm_init_continuations (); - scm_init_dynwind (); - scm_init_eq (); - scm_init_error (); - scm_init_fports (); - scm_init_files (); - scm_init_gc (); - scm_init_hash (); - scm_init_hashtab (); - scm_init_kw (); - scm_init_list (); - scm_init_lvectors (); - scm_init_numbers (); - scm_init_pairs (); - scm_init_ports (); - scm_init_procs (); - scm_init_procprop (); - scm_init_scmsigs (); - scm_init_stackchk (); - scm_init_strports (); - scm_init_struct (); - scm_init_symbols (); - scm_init_load (); - scm_init_print (); - scm_init_read (); - scm_init_sequences (); - scm_init_stime (); - scm_init_strings (); - scm_init_strorder (); - scm_init_mbstrings (); - scm_init_strop (); - scm_init_throw (); - scm_init_variable (); - scm_init_vectors (); - scm_init_version (); - scm_init_weaks (); - scm_init_vports (); - scm_init_eval (); - scm_init_ramap (); - scm_init_unif (); - scm_init_simpos (); - scm_init_elisp (); - scm_init_mallocs (); - scm_init_cnsvobj (); - scm_init_guile (); - initfn (); - - /* Save the argument list to be the return value of (program-arguments). - */ - scm_progargs = scm_makfromstrs (argc, argv); - - scm_gc_heap_lock = 0; - errno = 0; - scm_ints_disabled = 1; - -/* init_basic (); */ - -/* init_init(); */ - - if (initfile == NULL) - { - initfile = getenv ("GUILE_INIT_PATH"); - if (initfile == NULL) - initfile = SCM_IMPLINIT; - } - - if (initfile == NULL) - { - status = GSCM_OK; - } - else - { - SCM answer; - - status = gscm_seval_file (&answer, -1, initfile); - if ((status == GSCM_OK) && (answer == SCM_BOOL_F)) - status = GSCM_ERROR_OPENING_INIT_FILE; - } - - top = SCM_EOL; - - if (status == GSCM_OK) - { - scm_sysintern ("*stdin*", scm_cur_inp); - status = gscm_seval_str (0, top, initcmd); - } - return status; -} - - - - -void -scm_init_guile () -{ -#include "gscm.x" -} - diff --git a/libguile/gscm.h b/libguile/gscm.h deleted file mode 100644 index 7e0554e5e..000000000 --- a/libguile/gscm.h +++ /dev/null @@ -1,281 +0,0 @@ -/* classes: h_files */ - -#ifndef GSCMH -#define GSCMH - -/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile.h" - - -/* {Locking Out Async Execution (including async GC) and Non-Local Exits} - */ - -#define GSCM_DEFER_INTS SCM_DEFER_INTS -#define GSCM_ALLOW_INTS SCM_ALLOW_INTS - - -/* {Common Constants} - */ - -#define GSCM_EOL SCM_EOL -#define GSCM_FALSE SCM_BOOL_F -#define GSCM_TRUE SCM_BOOL_T - -#define GSCM_EOL_MARKER SCM_UNDEFINED -#define GSCM_NOT_PASSED SCM_UNDEFINED -#define GSCM_UNSPECIFIED SCM_UNSPECIFIED - - -/* {Booleans} - */ - -#define gscm_bool(CBOOL) ((CBOOL) ? SCM_BOOL_T : SCM_BOOL_F) -#define gscm_2_bool(BOOL) (((BOOL) == SCM_BOOL_F) ? 0 : 1) - - -/* {Numbers} - */ - -#define gscm_ulong scm_ulong2num -#define gscm_long scm_long2num -#define gscm_double(X) scm_makdbl ((X), 0.0) - -#define gscm_2_ulong(OBJ) scm_num2ulong((OBJ), (char *)SCM_ARG1, "gscm_2_ulong") -#define gscm_2_long(OBJ) scm_num2long((OBJ), (char *)SCM_ARG1, "gscm_2_long") -#define gscm_2_double(OBJ) scm_num2dbl((OBJ), "gscm_2_double") - - -/* {Characters} - */ - -#define gscm_char(C) SCM_MAKICHR(C) -/* extern int gscm_2_char P((SCM)); */ - - -/* {Strings} - */ - -#define gscm_str(SRC, LEN) scm_makfromstr (SRC, LEN, 0) -#define gscm_str0 scm_makfrom0str - - - -/* {Pairs and Lists} - */ - -#define gscm_cons scm_cons -#define gscm_list scm_listify -#define gscm_ilength scm_ilength - - -#define gscm_set_car(OBJ, VAL) \ - ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \ - ? (SCM_CAR(OBJ) = VAL) \ - : scm_wta ((OBJ), (char *)SCM_ARG1, "set-car!")) - -#define gscm_set_cdr(OBJ, VAL) \ - ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \ - ? (SCM_CDR(OBJ) = VAL) \ - : scm_wta ((OBJ), (char *)SCM_ARG1, "set-cdr!")) - - -#define GSCM_SAFE_CAR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \ - ? SCM_CAR(X) \ - : scm_wta ((X), (char *)SCM_ARG1, "car")) - -#define GSCM_SAFE_CDR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \ - ? SCM_CDR(X) \ - : scm_wta ((X), (char *)SCM_ARG1, "cdr")) - -#define gscm_car(OBJ) GSCM_SAFE_CAR (OBJ) -#define gscm_cdr(OBJ) GSCM_SAFE_CDR (OBJ) - -#define gscm_caar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)) -#define gscm_cdar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)) -#define gscm_cadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)) -#define gscm_cddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)) - -#define gscm_caaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cdaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))) -#define gscm_caadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))) -#define gscm_cdadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))) -#define gscm_caddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))) -#define gscm_cdddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))) - -#define gscm_caaaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdaaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cadaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cddaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdadar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caddar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caaadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cdaadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cadadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cddadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_caaddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cdaddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cadddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cddddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) - - -/* {Symbols} - */ - -#define gscm_symbol(STR, LEN) SCM_CAR(scm_intern (STR, LEN)) -#define gscm_tmp_symbol(STR, LEN) SCM_CAR(scm_intern_obarray (STR, LEN, SCM_BOOL_F)) - - -/* {Vectors} - */ - -#define gscm_vector(N, FILL) scm_make_vector (SCM_MAKINUM(N), (FILL), SCM_UNDEFINED) -#define gscm_vref(V, I) scm_vector_ref ((V), SCM_MAKINUM(I)) -#define gscm_vset(V, I, VAL) scm_vector_set_x ((V), SCM_MAKINUM(I), (VAL)) - - -/* {Procedures} - */ - -/* extern SCM gscm_make_subr P((SCM (*fn)(), int req, int opt, int varp, char * doc)); */ -/* extern SCM gscm_curry P((SCM procedure, SCM first_arg)); */ - -#define gscm_apply(PROC, ARGS) scm_apply ((PROC), (ARGS), SCM_EOL) - - - -/* {Non-local Exits} - */ - - -#define gscm_catch(T, TH, H) scm_catch ((T), (TH), (H)) -#define gscm_throw(T, V) scm_throw ((T), (V)) -#define gscm_dynamic_wind(E, T, L) scm_dynwind ((E), (T), (L)) -/* extern void gscm_error P((char * message, SCM args)); */ - - -/* {I/O} - */ - -#define gscm_print_obj scm_prin1 -#define gscm_putc scm_putc -#define gscm_puts scm_puts -#define gscm_fwrite scm_fwrite -#define gscm_flush scm_flush - -extern char * gscm_last_attempted_init_file; - -/* {Equivalence} - */ - - -#define gscm_is_eq(OBJ) (SCM_BOOL_F != scm_eq (OBJ)) -#define gscm_is_eqv(OBJ) (SCM_BOOL_F != scm_eqv (OBJ)) -#define gscm_is_equal(OBJ) (SCM_BOOL_F != scm_equal_p (OBJ)) - - -/* {Procedure Properties} - */ - -#define gscm_procedure_properties scm_procedure_properties -#define gscm_set_procedure_properties_x scm_set_procedure_properties_x -#define gscm_procedure_property scm_procedure_property -#define gscm_set_procedure_property_x scm_set_procedure_property_x - - -/* {Generic Length Procedure} - */ - -#define gscm_obj_length scm_obj_length - - -/* {Proc Declaration Macro} - */ -#ifndef GSCM_MAGIC_SNARFER -#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \ - static char RANAME[]=STR; -#else -#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \ -%%% gscm_define_procedure (RANAME, CFN, REQ, OPT, VAR, "") -#endif - -#define gscm_define_procedure(NAME, FN, REQ, OPT, VARP, DOC) scm_make_gsubr(name, req, opt, varp, fn) -#define gscm_curry scm_curry -#define gscm_define scm_sysintern - - -typedef int GSCM_top_level; - - -/* {Error Returns} - */ - -typedef int GSCM_status; - -#define GSCM_OK 0 -#define GSCM_ERROR 1 -#define GSCM_ILLEGALLY_REENTERED 2 -#define GSCM_OUT_OF_MEM 3 -#define GSCM_ERROR_OPENING_FILE 4 -#define GSCM_ERROR_OPENING_INIT_FILE 5 - - - -extern GSCM_status gscm_seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); -extern GSCM_status gscm_seval_file SCM_P ((SCM *answer, GSCM_top_level toplvl, char * file_name)); -extern GSCM_status gscm_eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); -extern GSCM_status gscm_eval_file SCM_P ((char ** answer, GSCM_top_level toplvl, char * file_name)); -extern GSCM_status gscm_run_scm SCM_P ((int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(void), char * initfile, char * initcmd)); -extern char * gscm_error_msg SCM_P ((int n)); -extern SCM gscm_make_subr SCM_P ((SCM (*fn)(), int req, int opt, int varp, char * doc)); -extern int gscm_2_char SCM_P ((SCM c)); -extern void gscm_2_str SCM_P ((char ** out, int * len_out, SCM * objp)); -extern void gscm_error SCM_P ((char * message, SCM args)); -extern void scm_init_guile SCM_P ((void)); - -#endif /* GSCMH */ - diff --git a/libguile/gsubr.c b/libguile/gsubr.c deleted file mode 100644 index b69a6c497..000000000 --- a/libguile/gsubr.c +++ /dev/null @@ -1,193 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "procprop.h" - -#include "gsubr.h" - -/* - * gsubr.c - * Provide `gsubrs' -- subrs taking a prescribed number of required, optional, - * and rest arguments. - */ - -#include "gsubr.h" - -#define GSUBR_TEST 1 - -#define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8)) -#define GSUBR_REQ(x) ((int)(x)&0xf) -#define GSUBR_OPT(x) (((int)(x)&0xf0)>>4) -#define GSUBR_REST(x) ((int)(x)>>8) - -#define GSUBR_MAX 10 -#define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1]) -#define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2]) - -SCM scm_i_name; -static SCM f_gsubr_apply; - -SCM -scm_make_gsubr(name, req, opt, rst, fcn) - char *name; - int req; - int opt; - int rst; - SCM (*fcn)(); -{ - switch GSUBR_MAKTYPE(req, opt, rst) { - case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn); - case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn); - case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn); - case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn); - case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn); - case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn); - case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn); - case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); - default: - { - SCM symcell = scm_sysintern(name, SCM_UNDEFINED); - SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L); - long tmp = ((((SCM_CELLPTR)(SCM_CAR(symcell)))-scm_heap_org)<<8); - if (GSUBR_MAX < req + opt + rst) { - fputs("ERROR in scm_make_gsubr: too many args\n", stderr); - exit (1); - } - if ((tmp>>8) != ((SCM_CELLPTR)(SCM_CAR(symcell))-scm_heap_org)) - tmp = 0; - SCM_NEWCELL(z); - SCM_SUBRF(z) = fcn; - SCM_SETCAR (z, tmp + scm_tc7_subr_0); - GSUBR_PROC(cclo) = z; - GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); - SCM_SETCDR (symcell, cclo); -#ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_i_name, SCM_CAR (symcell)); -#endif - return cclo; - } - } -} - - -SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply); - -SCM -scm_gsubr_apply(args) - SCM args; -{ - SCM self = SCM_CAR(args); - SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self)); - SCM v[10]; /* must agree with greatest supported arity */ - int typ = SCM_INUM(GSUBR_TYPE(self)); - int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ); - args = SCM_CDR(args); - for (i = 0; i < GSUBR_REQ(typ); i++) { -#ifndef RECKLESS - if (SCM_IMP(args)) - scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self))); -#endif - v[i] = SCM_CAR(args); - args = SCM_CDR(args); - } - for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) { - if (SCM_NIMP(args)) { - v[i] = SCM_CAR(args); - args = SCM_CDR(args); - } - else - v[i] = SCM_UNDEFINED; - } - if (GSUBR_REST(typ)) - v[i] = args; - switch (n) { - default: scm_wta(self, "internal programming error", s_gsubr_apply); - case 2: return (*fcn)(v[0], v[1]); - case 3: return (*fcn)(v[0], v[1], v[2]); - case 4: return (*fcn)(v[0], v[1], v[2], v[3]); - case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]); - case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]); - case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]); - case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]); - case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]); - case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]); - } -} - - -#ifdef GSUBR_TEST -/* A silly example, taking 2 required args, 1 optional, and - a scm_list of rest args - */ -SCM -gsubr_21l(req1, req2, opt, rst) - SCM req1, req2, opt, rst; -{ - scm_gen_puts (scm_regular_string, "gsubr-2-1-l:\n req1: ", scm_cur_outp); - scm_display(req1, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n req2: ", scm_cur_outp); - scm_display(req2, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n opt: ", scm_cur_outp); - scm_display(opt, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n rest: ", scm_cur_outp); - scm_display(rst, scm_cur_outp); - scm_newline(scm_cur_outp); - return SCM_UNSPECIFIED; -} -#endif - - - -void -scm_init_gsubr() -{ - f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); - scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); - scm_permanent_object (scm_i_name); -#ifdef GSUBR_TEST - scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ -#endif -} diff --git a/libguile/gsubr.h b/libguile/gsubr.h deleted file mode 100644 index 7eb34ce02..000000000 --- a/libguile/gsubr.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef GSUBRH -#define GSUBRH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)())); -extern SCM scm_gsubr_apply SCM_P ((SCM args)); -extern void scm_init_gsubr SCM_P ((void)); - -#endif /* GSUBRH */ diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in deleted file mode 100644 index e9254cdbc..000000000 --- a/libguile/guile-snarf.in +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/sh -# Extract the initialization actions for builtin things. - -@CPP@ -DSCM_MAGIC_SNARFER $* | grep "^%%%" | sed -e "s/^%%%//" diff --git a/libguile/hash.c b/libguile/hash.c deleted file mode 100644 index 3ea9f866a..000000000 --- a/libguile/hash.c +++ /dev/null @@ -1,222 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "hash.h" - - -#ifndef floor -extern double floor(); -#endif - - -unsigned long -scm_hasher(obj, n, d) - SCM obj; - unsigned long n; - scm_sizet d; -{ - switch (7 & (int) obj) { - case 2: case 6: /* SCM_INUMP(obj) */ - return SCM_INUM(obj) % n; - case 4: - if SCM_ICHRP(obj) - return (unsigned)(scm_downcase(SCM_ICHR(obj))) % n; - switch ((int) obj) { -#ifndef SICP - case (int) SCM_EOL: d = 256; break; -#endif - case (int) SCM_BOOL_T: d = 257; break; - case (int) SCM_BOOL_F: d = 258; break; - case (int) SCM_EOF_VAL: d = 259; break; - default: d = 263; /* perhaps should be error */ - } - return d % n; - default: return 263 % n; /* perhaps should be error */ - case 0: - switch SCM_TYP7(obj) { - default: return 263 % n; - case scm_tc7_smob: - switch SCM_TYP16(obj) { - case scm_tcs_bignums: - bighash: return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); - default: return 263 % n; -#ifdef SCM_FLOATS - case scm_tc16_flo: - if SCM_REALP(obj) { - double r = SCM_REALPART(obj); - if (floor(r)==r) { - obj = scm_inexact_to_exact (obj); - if SCM_IMP(obj) return SCM_INUM(obj) % n; - goto bighash; - } - } - obj = scm_number_to_string(obj, SCM_MAKINUM(10)); -#endif - } - case scm_tcs_symbols: - case scm_tc7_string: - case scm_tc7_mb_string: - case scm_tc7_substring: - case scm_tc7_mb_substring: - return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n); - case scm_tc7_wvect: - case scm_tc7_vector: - { - scm_sizet len = SCM_LENGTH(obj); - SCM *data = SCM_VELTS(obj); - if (len>5) - { - scm_sizet i = d/2; - unsigned long h = 1; - while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n; - return h; - } - else - { - scm_sizet i = len; - unsigned long h = (n)-1; - while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n; - return h; - } - } - case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: - if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n; - else return 1; - case scm_tc7_port: - return ((SCM_RDNG & SCM_CAR(obj)) ? 260 : 261) % n; - case scm_tcs_closures: case scm_tc7_contin: case scm_tcs_subrs: - return 262 % n; - } - } -} - - - - - -unsigned int -scm_ihashq (obj, n) - SCM obj; - unsigned int n; -{ - return (((unsigned int) obj) >> 1) % n; -} - - -SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq); - -SCM -scm_hashq(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq); - return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n))); -} - - - - - -unsigned int -scm_ihashv (obj, n) - SCM obj; - unsigned int n; -{ - if (SCM_ICHRP(obj)) - return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */ - - if (SCM_NIMP(obj) && SCM_NUMP(obj)) - return (unsigned int) scm_hasher(obj, n, 10); - else - return ((unsigned int)obj) % n; -} - - -SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv); - -SCM -scm_hashv(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv); - return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n))); -} - - - - - -unsigned int -scm_ihash (obj, n) - SCM obj; - unsigned int n; -{ - return (unsigned int)scm_hasher (obj, n, 10); -} - -SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash); - -SCM -scm_hash(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash); - return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n))); -} - - - - - -void -scm_init_hash () -{ -#include "hash.x" -} - diff --git a/libguile/hash.h b/libguile/hash.h deleted file mode 100644 index b9637d0c0..000000000 --- a/libguile/hash.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef HASHH -#define HASHH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern unsigned long scm_hasher SCM_P ((SCM obj, unsigned long n, scm_sizet d)); -extern unsigned int scm_ihashq SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hashq SCM_P ((SCM obj, SCM n)); -extern unsigned int scm_ihashv SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hashv SCM_P ((SCM obj, SCM n)); -extern unsigned int scm_ihash SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hash SCM_P ((SCM obj, SCM n)); -extern void scm_init_hash SCM_P ((void)); - -#endif /* HASHH */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c deleted file mode 100644 index a3cd76499..000000000 --- a/libguile/hashtab.c +++ /dev/null @@ -1,540 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "alist.h" -#include "hash.h" -#include "eval.h" - -#include "hashtab.h" - - - -SCM -scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - int k; - SCM h; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_get_handle"); - h = assoc_fn (obj, SCM_VELTS (table)[k], closure); - return h; -} - - - -SCM -scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM init; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - int k; - SCM it; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_create_handle_x"); - SCM_REDEFER_INTS; - it = assoc_fn (obj, SCM_VELTS (table)[k], closure); - if (SCM_NIMP (it)) - { - return it; - } - { - SCM new_bucket; - SCM old_bucket; - old_bucket = SCM_VELTS (table)[k]; - new_bucket = scm_acons (obj, init, old_bucket); - SCM_VELTS(table)[k] = new_bucket; - SCM_REALLOW_INTS; - return SCM_CAR (new_bucket); - } -} - - - - -SCM -scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM dflt; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - SCM it; - - it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); - if (SCM_IMP (it)) - return dflt; - else - return SCM_CDR (it); -} - - - - -SCM -scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM val; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - SCM it; - - it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure); - SCM_SETCDR (it, val); - return val; -} - - - - - -SCM -scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - SCM (*delete_fn)(); - void * closure; -{ - int k; - SCM h; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_remove_x"); - h = assoc_fn (obj, SCM_VELTS (table)[k], closure); - SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]); - return h; -} - - - - -SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle); - -SCM -scm_hashq_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); -} - - -SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x); - -SCM -scm_hashq_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0); -} - - -SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref); - -SCM -scm_hashq_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0); -} - - - -SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x); - -SCM -scm_hashq_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); -} - - - -SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x); - -SCM -scm_hashq_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); -} - - - - -SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle); - -SCM -scm_hashv_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x); - -SCM -scm_hashv_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref); - -SCM -scm_hashv_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0); -} - - - -SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x); - -SCM -scm_hashv_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x); - -SCM -scm_hashv_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); -} - - - -SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle); - -SCM -scm_hash_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); -} - - -SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x); - -SCM -scm_hash_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0); -} - - -SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref); - -SCM -scm_hash_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0); -} - - - -SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x); - -SCM -scm_hash_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); -} - - - -SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x); - -SCM -scm_hash_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); -} - - - - -struct scm_ihashx_closure -{ - SCM hash; - SCM assoc; - SCM delete; -}; - - - -static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure)); - -static unsigned int -scm_ihashx (obj, n, closure) - SCM obj; - unsigned int n; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->hash, - scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return SCM_INUM (answer); -} - - - -static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - -static SCM -scm_sloppy_assx (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->assoc, - scm_listify (obj, alist, SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return answer; -} - - - - -static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - -static SCM -scm_delx_x (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->delete, - scm_listify (obj, alist, SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return answer; -} - - - -SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle); - -SCM -scm_hashx_get_handle (hash, assoc, table, obj) - SCM hash; - SCM assoc; - SCM table; - SCM obj; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - -SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x); - -SCM -scm_hashx_create_handle_x (hash, assoc, table, obj, init) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM init; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - -SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref); - -SCM -scm_hashx_ref (hash, assoc, table, obj, dflt) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM dflt; -{ - struct scm_ihashx_closure closure; - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - - -SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x); - -SCM -scm_hashx_set_x (hash, assoc, table, obj, val) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM val; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - -SCM -scm_hashx_remove_x (hash, assoc, delete, table, obj) - SCM hash; - SCM assoc; - SCM delete; - SCM table; - SCM obj; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - closure.delete = delete; - return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0); -} - - - - -void -scm_init_hashtab () -{ -#include "hashtab.x" -} - diff --git a/libguile/hashtab.h b/libguile/hashtab.h deleted file mode 100644 index f53d25663..000000000 --- a/libguile/hashtab.h +++ /dev/null @@ -1,84 +0,0 @@ -/* classes: h_files */ - -#ifndef HASHTABH -#define HASHTABH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -#if 0 -typedef unsigned int scm_hash_fn_t SCM_P ((SCM obj, unsigned int d, void *closure)); -typedef SCM scm_assoc_fn_t SCM_P ((SCM key, SCM alist, void *closure)); -typedef SCM scm_delete_fn_t SCM_P ((SCM elt, SCM list)); -#endif - -extern SCM scm_hash_fn_get_handle SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_create_handle_x SCM_P ((SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_ref SCM_P ((SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_set_x SCM_P ((SCM table, SCM obj, SCM val, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_remove_x SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure)); - -extern SCM scm_hashq_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashq_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hashq_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashq_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hashq_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashv_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashv_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hashv_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashv_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hashv_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hash_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hash_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hash_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hash_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hash_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashx_get_handle SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj)); -extern SCM scm_hashx_create_handle_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM init)); -extern SCM scm_hashx_ref SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashx_set_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM val)); -extern SCM scm_hashx_remove_x SCM_P ((SCM hash, SCM assoc, SCM del, SCM table, SCM obj)); -extern void scm_init_hashtab SCM_P ((void)); - -#endif /* HASHTABH */ diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c deleted file mode 100644 index 1d02af5e5..000000000 --- a/libguile/inet_aton.c +++ /dev/null @@ -1,157 +0,0 @@ -/* - * Copyright (c) 1983, 1990, 1993 - * The Regents of the University of California. All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. All advertising materials mentioning features or use of this software - * must display the following acknowledgement: - * This product includes software developed by the University of - * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -#if defined(LIBC_SCCS) && !defined(lint) -static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93"; -#endif /* LIBC_SCCS and not lint */ - -#include <ctype.h> - -#include <sys/param.h> -#include <netinet/in.h> -#include <arpa/inet.h> - -#if 0 - -/* - * Ascii internet address interpretation routine. - * The value returned is in network order. - */ -u_long -inet_addr(cp) - register const char *cp; -{ - struct in_addr val; - - if (inet_aton(cp, &val)) - return (val.s_addr); - return (INADDR_NONE); -} - -#endif - -/* - * Check whether "cp" is a valid ascii representation - * of an Internet address and convert to a binary address. - * Returns 1 if the address is valid, 0 if not. - * This replaces inet_addr, the return value from which - * cannot distinguish between failure and a local broadcast address. - */ -int -inet_aton(cp, addr) - register const char *cp; - struct in_addr *addr; -{ - register unsigned long val; - register int base, n; - register char c; - unsigned int parts[4]; - register unsigned int *pp = parts; - - for (;;) { - /* - * Collect number up to ``.''. - * Values are specified as for C: - * 0x=hex, 0=octal, other=decimal. - */ - val = 0; base = 10; - if (*cp == '0') { - if (*++cp == 'x' || *cp == 'X') - base = 16, cp++; - else - base = 8; - } - while ((c = *cp) != '\0') { - if (isascii(c) && isdigit(c)) { - val = (val * base) + (c - '0'); - cp++; - continue; - } - if (base == 16 && isascii(c) && isxdigit(c)) { - val = (val << 4) + - (c + 10 - (islower(c) ? 'a' : 'A')); - cp++; - continue; - } - break; - } - if (*cp == '.') { - /* - * Internet format: - * a.b.c.d - * a.b.c (with c treated as 16-bits) - * a.b (with b treated as 24 bits) - */ - if (pp >= parts + 3 || val > 0xff) - return (0); - *pp++ = val, cp++; - } else - break; - } - /* - * Check for trailing characters. - */ - if (*cp && (!isascii(*cp) || !isspace(*cp))) - return (0); - /* - * Concoct the address according to - * the number of parts specified. - */ - n = pp - parts + 1; - switch (n) { - - case 1: /* a -- 32 bits */ - break; - - case 2: /* a.b -- 8.24 bits */ - if (val > 0xffffff) - return (0); - val |= parts[0] << 24; - break; - - case 3: /* a.b.c -- 8.8.16 bits */ - if (val > 0xffff) - return (0); - val |= (parts[0] << 24) | (parts[1] << 16); - break; - - case 4: /* a.b.c.d -- 8.8.8.8 bits */ - if (val > 0xff) - return (0); - val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); - break; - } - if (addr) - addr->s_addr = htonl(val); - return (1); -} diff --git a/libguile/init.c b/libguile/init.c deleted file mode 100644 index edbffd208..000000000 --- a/libguile/init.c +++ /dev/null @@ -1,454 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -/* Everybody has an init function. */ -#include "alist.h" -#include "append.h" -#include "arbiters.h" -#include "async.h" -#include "backtrace.h" -#include "boolean.h" -#include "chars.h" -#include "continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "dynl.h" -#include "dynwind.h" -#include "eq.h" -#include "error.h" -#include "eval.h" -#include "fdsocket.h" -#include "feature.h" -#include "filesys.h" -#include "fports.h" -#include "gc.h" -#include "gdbint.h" -#include "gsubr.h" -#include "hash.h" -#include "hashtab.h" -#include "ioext.h" -#include "kw.h" -#include "list.h" -#include "load.h" -#include "mallocs.h" -#include "mbstrings.h" -#include "numbers.h" -#include "objprop.h" -#include "options.h" -#include "pairs.h" -#include "ports.h" -#include "posix.h" -#include "print.h" -#include "procprop.h" -#include "procs.h" -#include "ramap.h" -#include "read.h" -#include "scmsigs.h" -#include "sequences.h" -#include "simpos.h" -#include "smob.h" -#include "socket.h" -#include "srcprop.h" -#include "stackchk.h" -#include "stacks.h" -#include "stime.h" -#include "strings.h" -#include "strop.h" -#include "strorder.h" -#include "strports.h" -#include "struct.h" -#include "symbols.h" -#include "tag.h" -#include "throw.h" -#include "unif.h" -#include "variable.h" -#include "vectors.h" -#include "version.h" -#include "vports.h" -#include "weaks.h" - -#include "init.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -static void scm_start_stack SCM_P ((void *base)); -static void scm_restart_stack SCM_P ((void * base)); - -static void -scm_start_stack (base) - void * base; -{ - SCM root; - - root = scm_permanent_object (scm_make_root (SCM_UNDEFINED)); - scm_set_root (SCM_ROOT_STATE (root)); - scm_stack_base = base; - - scm_exitval = SCM_BOOL_F; /* vestigial */ - - scm_top_level_lookup_closure_var = SCM_BOOL_F; - scm_system_transformer = SCM_BOOL_F; - - /* Create an object to hold the root continuation. - */ - SCM_NEWCELL (scm_rootcont); - SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs), - "continuation")); - SCM_SETCAR (scm_rootcont, scm_tc7_contin); - SCM_SEQ (scm_rootcont) = 0; - /* The root continuation if further initialized by scm_restart_stack. */ - - /* Create the look-aside stack for variables that are shared between - * captured continuations. - */ - scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), - SCM_UNDEFINED, SCM_UNDEFINED); - /* The continuation stack is further initialized by scm_restart_stack. */ - - /* The remainder of stack initialization is factored out to another - * function so that if this stack is ever exitted, it can be - * re-entered using scm_restart_stack. */ - scm_restart_stack (base); -} - - -static void -scm_restart_stack (base) - void * base; -{ - scm_dynwinds = SCM_EOL; - SCM_DYNENV (scm_rootcont) = SCM_EOL; - SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; -#endif - SCM_BASE (scm_rootcont) = base; - scm_continuation_stack_ptr = SCM_MAKINUM (0); -} - -#if 0 -static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; - - -static void fixconfig SCM_P ((char *s1, char *s2, int s)); - -static void -fixconfig (s1, s2, s) - char *s1; - char *s2; - int s; -{ - fputs (s1, stderr); - fputs (s2, stderr); - fputs ("\nin ", stderr); - fputs (s ? "setjump" : "scmfig", stderr); - fputs (".h and recompile scm\n", stderr); - exit (1); -} - - -static void check_config SCM_P ((void)); - -static void -check_config () -{ - scm_sizet j; - - j = HEAP_SEG_SIZE; - if (HEAP_SEG_SIZE != j) - fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0); - -#ifdef SCM_SINGLES - if (sizeof (float) != sizeof (long)) - fixconfig (remsg, "SCM_SINGLES", 0); -#endif /* def SCM_SINGLES */ - - -#ifdef SCM_BIGDIG - if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long)) - fixconfig (remsg, "SCM_BIGDIG", 0); -#ifndef SCM_DIGSTOOBIG - if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long)) - fixconfig (addmsg, "SCM_DIGSTOOBIG", 0); -#endif -#endif - -#ifdef SCM_STACK_GROWS_UP - if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0) - fixconfig (remsg, "SCM_STACK_GROWS_UP", 1); -#else - if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0) - fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1); -#endif -} -#endif - - - -/* initializing standard and current I/O ports */ - -/* Create standard ports from stdio stdin, stdout, and stderr. */ -static void -scm_init_standard_ports () -{ - /* I'm not sure why this should be unbuffered when coming from a - tty; isn't line buffering more common? */ - scm_def_inp = scm_stdio_to_port (stdin, - (isatty (fileno (stdin)) ? "r0" : "r"), - "standard input"); - scm_def_outp = scm_stdio_to_port (stdout, "w", "standard output"); - scm_def_errp = scm_stdio_to_port (stderr, "w", "standard error"); - - scm_cur_inp = scm_def_inp; - scm_cur_outp = scm_def_outp; - scm_cur_errp = scm_def_errp; -} - - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - -static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, - int argc, char **argv, - void (*main_func) (void *closure, - int argc, - char **argv), - void *closure)); - - -/* Fire up the Guile Scheme interpreter. - - Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC - should do all the work of the program (initializing other packages, - reading user input, etc.) before returning. When MAIN_FUNC - returns, call exit (0); this function never returns. If you want - some other exit value, MAIN_FUNC may call exit itself. - - scm_boot_guile arranges for program-arguments to return the strings - given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should - call scm_set_program_arguments with the final list, so Scheme code - will know which arguments have been processed. - - Why must the caller do all the real work from MAIN_FUNC? The - garbage collector assumes that all local variables of type SCM will - be above scm_boot_guile's stack frame on the stack. If you try to - manipulate SCM values after this function returns, it's the luck of - the draw whether the GC will be able to find the objects you - allocate. So, scm_boot_guile function exits, rather than - returning, to discourage people from making that mistake. */ - - -void -scm_boot_guile (argc, argv, main_func, closure) - int argc; - char ** argv; - void (*main_func) (); - void *closure; -{ - /* The garbage collector uses the address of this variable as one - end of the stack, and the address of one of its own local - variables as the other end. */ - SCM_STACKITEM dummy; - - return scm_boot_guile_1 (&dummy, argc, argv, main_func, closure); -} - -/* Record here whether SCM_BOOT_GUILE_1 has already been called. This - variable is now here and not inside SCM_BOOT_GUILE_1 so that one - can tweak it. This is necessary for unexec to work. (Hey, "1-live" - is the name of a local radiostation...) */ - -int scm_boot_guile_1_live = 0; - -static void -scm_boot_guile_1 (base, argc, argv, main_func, closure) - SCM_STACKITEM *base; - int argc; - char **argv; - void (*main_func) (); - void *closure; -{ - static int initialized = 0; - /* static int live = 0; */ - setjmp_type setjmp_val; - - /* This function is not re-entrant. */ - if (scm_boot_guile_1_live) - abort (); - - scm_boot_guile_1_live = 1; - - scm_ints_disabled = 1; - scm_block_gc = 1; - - if (initialized) - { - scm_restart_stack (base); - } - else - { - scm_ports_prehistory (); - scm_smob_prehistory (); - scm_tables_prehistory (); - scm_init_storage (0); - scm_init_root (); -#ifdef USE_THREADS - scm_init_threads (base); -#endif - scm_start_stack (base); - scm_init_gsubr (); - scm_init_feature (); - scm_init_alist (); - scm_init_append (); - scm_init_arbiters (); - scm_init_async (); - scm_init_backtrace (); - scm_init_boolean (); - scm_init_chars (); - scm_init_continuations (); - scm_init_dynwind (); - scm_init_eq (); - scm_init_error (); - scm_init_fdsocket (); - scm_init_fports (); - scm_init_filesys (); - scm_init_gc (); - scm_init_gdbint (); - scm_init_hash (); - scm_init_hashtab (); - scm_init_ioext (); - scm_init_kw (); - scm_init_list (); - scm_init_mallocs (); - scm_init_numbers (); - scm_init_objprop (); -#if DEBUG_EXTENSIONS - /* Excluding this until it's really needed makes the binary - * smaller after linking. */ - scm_init_options (); -#endif - scm_init_pairs (); - scm_init_ports (); - scm_init_posix (); - scm_init_procs (); - scm_init_procprop (); - scm_init_scmsigs (); - scm_init_socket (); -#ifdef DEBUG_EXTENSIONS - scm_init_srcprop (); -#endif - scm_init_stackchk (); - scm_init_struct (); /* Requires struct */ - scm_init_stacks (); - scm_init_strports (); - scm_init_symbols (); - scm_init_tag (); - scm_init_load (); - scm_init_print (); /* Requires struct */ - scm_init_read (); - scm_init_sequences (); - scm_init_stime (); - scm_init_strings (); - scm_init_strorder (); - scm_init_mbstrings (); - scm_init_strop (); - scm_init_throw (); - scm_init_variable (); - scm_init_vectors (); - scm_init_version (); - scm_init_weaks (); - scm_init_vports (); - scm_init_eval (); -#ifdef DEBUG_EXTENSIONS - scm_init_debug (); /* Requires macro smobs */ -#endif - scm_init_ramap (); - scm_init_unif (); - scm_init_simpos (); - scm_init_load_path (); - scm_init_standard_ports (); - scm_init_dynamic_linking (); - initialized = 1; - } - - scm_block_gc = 0; /* permit the gc to run */ - /* ints still disabled */ - -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - - setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont)); - if (!setjmp_val) - { - scm_init_signals (); - - scm_set_program_arguments (argc, argv, 0); - (*main_func) (closure, argc, argv); - } - - scm_restore_signals (); - - /* This tick gives any pending - * asyncs a chance to run. This must be done after - * the call to scm_restore_signals. - */ - SCM_ASYNC_TICK; - - /* If the caller doesn't want this, they should return from - main_func themselves. */ - exit (0); -} diff --git a/libguile/init.h b/libguile/init.h deleted file mode 100644 index 97fb5e182..000000000 --- a/libguile/init.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef INITH -#define INITH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern void scm_boot_guile SCM_P ((int argc, char **argv, - void (*main_func) (void *closure, - int argc, - char **argv), - void *closure)); - -#endif /* INITH */ diff --git a/libguile/ioext.c b/libguile/ioext.c deleted file mode 100644 index 37b8bdc34..000000000 --- a/libguile/ioext.c +++ /dev/null @@ -1,458 +0,0 @@ -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - -#include <stdio.h> -#include "fd.h" -#include "_scm.h" -#include "fports.h" - -#include "ioext.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell); - -SCM -scm_sys_ftell (port) - SCM port; -{ - long pos; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell); - SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port))); - if (pos < 0) - scm_syserror (s_sys_ftell); - if (pos > 0 && SCM_CRDYP (port)) - pos--; - return scm_long2num (pos); -} - - - -SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek); - -SCM -scm_sys_fseek (port, offset, whence) - SCM port; - SCM offset; - SCM whence; -{ - int rv; - long loff; - - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek); - loff = scm_num2long (offset, (char *)SCM_ARG2, s_sys_fseek); - SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0), - whence, SCM_ARG3, s_sys_fseek); - - SCM_CLRDY (port); /* Clear ungetted char */ - /* Values of whence are interned in scm_init_ioext. */ - rv = fseek ((FILE *)SCM_STREAM (port), loff, SCM_INUM (whence)); - if (rv != 0) - scm_syserror (s_sys_fseek); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen); - -SCM -scm_sys_freopen (filename, modes, port) - SCM filename; - SCM modes; - SCM port; -{ - FILE *f; - SCM_ASSERT (SCM_NIMP (filename) && SCM_STRINGP (filename), filename, SCM_ARG1, s_sys_freopen); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_freopen); - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_sys_freopen); - SCM_SYSCALL (f = freopen (SCM_CHARS (filename), SCM_CHARS (modes), (FILE *)SCM_STREAM (port))); - if (!f) - { - SCM p; - p = port; - port = SCM_MAKINUM (errno); - SCM_SETAND_CAR (p, ~SCM_OPN); - scm_remove_from_port_table (p); - } - else - { - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - SCM_SETSTREAM (port, (SCM)f); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - } - SCM_ALLOW_INTS; - return port; -} - - - -SCM_PROC (s_sys_duplicate_port, "duplicate-port", 2, 0, 0, scm_sys_duplicate_port); - -SCM -scm_sys_duplicate_port (oldpt, modes) - SCM oldpt; - SCM modes; -{ - int oldfd; - int newfd; - FILE *f; - SCM newpt; - SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, s_sys_duplicate_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_duplicate_port); - SCM_NEWCELL (newpt); - SCM_DEFER_INTS; - oldfd = fileno ((FILE *)SCM_STREAM (oldpt)); - if (oldfd == -1) - scm_syserror (s_sys_duplicate_port); - SCM_SYSCALL (newfd = dup (oldfd)); - if (newfd == -1) - scm_syserror (s_sys_duplicate_port); - f = fdopen (newfd, SCM_CHARS (modes)); - if (!f) - { - SCM_SYSCALL (close (newfd)); - scm_syserror (s_sys_duplicate_port); - } - { - struct scm_port_table * pt; - pt = scm_add_to_port_table (newpt); - SCM_SETPTAB_ENTRY (newpt, pt); - SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (newpt)) - scm_setbuf0 (newpt); - SCM_SETSTREAM (newpt, (SCM)f); - SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name; - } - SCM_ALLOW_INTS; - return newpt; -} - - - -SCM_PROC (s_sys_redirect_port, "redirect-port", 2, 0, 0, scm_sys_redirect_port); - -SCM -scm_sys_redirect_port (into_pt, from_pt) - SCM into_pt; - SCM from_pt; -{ - int ans, oldfd, newfd; - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port); - SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port); - oldfd = fileno ((FILE *)SCM_STREAM (into_pt)); - if (oldfd == -1) - scm_syserror (s_sys_redirect_port); - newfd = fileno ((FILE *)SCM_STREAM (from_pt)); - if (newfd == -1) - scm_syserror (s_sys_redirect_port); - SCM_SYSCALL (ans = dup2 (oldfd, newfd)); - if (ans == -1) - scm_syserror (s_sys_redirect_port); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_sys_fileno, "fileno", 1, 0, 0, scm_sys_fileno); - -SCM -scm_sys_fileno (port) - SCM port; -{ - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_sys_fileno); - return SCM_MAKINUM (fd); -} - -SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p); - -SCM -scm_sys_isatty_p (port) - SCM port; -{ - int rv; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty); - rv = fileno ((FILE *)SCM_STREAM (port)); - if (rv == -1) - scm_syserror (s_sys_isatty); - rv = isatty (rv); - return rv ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen); - -SCM -scm_sys_fdopen (fdes, modes) - SCM fdes; - SCM modes; -{ - FILE *f; - SCM port; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen); - SCM_NEWCELL (port); - SCM_DEFER_INTS; - f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes)); - if (f == NULL) - scm_syserror (s_sys_fdopen); - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_SETSTREAM (port, (SCM)f); - SCM_ALLOW_INTS; - return port; -} - - - -/* Move a port's underlying file descriptor to a given value. - * Returns #f if fdes is already the given value. - * #t if fdes moved. - * MOVE->FDES is implemented in Scheme and calls this primitive. - */ -SCM_PROC (s_sys_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes); - -SCM -scm_sys_primitive_move_to_fdes (port, fd) - SCM port; - SCM fd; -{ - FILE *stream; - int old_fd; - int new_fd; - int rv; - - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_primitive_move_to_fdes); - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_sys_primitive_move_to_fdes); - SCM_DEFER_INTS; - stream = (FILE *)SCM_STREAM (port); - old_fd = fileno (stream); - new_fd = SCM_INUM (fd); - if (old_fd == new_fd) - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - scm_evict_ports (new_fd); - rv = dup2 (old_fd, new_fd); - if (rv == -1) - scm_syserror (s_sys_primitive_move_to_fdes); - scm_setfileno (stream, new_fd); - SCM_SYSCALL (close (old_fd)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; -} - - -void -scm_setfileno (fs, fd) - FILE *fs; - int fd; -{ -#ifdef SET_FILE_FD_FIELD - SET_FILE_FD_FIELD(fs, fd); -#else - Configure could not guess the name of the correct field in a FILE *. - - This function needs to be ported to your system. - - SET_FILE_FD_FIELD should change the descriptor refered to by a stdio - stream, and nothing else. - - The way to port this file is to add cases to configure.in. Search - that file for "SET_FILE_FD_FIELD" and follow the examples there. -#endif -} - -/* Move ports with the specified file descriptor to new descriptors, - * reseting the revealed count to 0. - * Should be called with SCM_DEFER_INTS active. - */ - -void -scm_evict_ports (fd) - int fd; -{ - int i; - - for (i = 0; i < scm_port_table_size; i++) - { - if (SCM_FPORTP (scm_port_table[i]->port) - && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd) - { - scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd)); - scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0)); - } - } -} - -/* Return a list of ports using a given file descriptor. */ -SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports); - -SCM -scm_fdes_to_ports (fd) - SCM fd; -{ - SCM result = SCM_EOL; - int int_fd; - int i; - - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports); - int_fd = SCM_INUM (fd); - - SCM_DEFER_INTS; - for (i = 0; i < scm_port_table_size; i++) - { - if (SCM_FPORTP (scm_port_table[i]->port) - && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd) - result = scm_cons (scm_port_table[i]->port, result); - } - SCM_ALLOW_INTS; - return result; -} - - -void -scm_init_ioext () -{ - /* fseek() symbols. */ - scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); - scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); - scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); - - /* File type/permission bits. */ -#ifdef S_IRUSR - scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR)); -#endif -#ifdef S_IWUSR - scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR)); -#endif -#ifdef S_IXUSR - scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR)); -#endif -#ifdef S_IRWXU - scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU)); -#endif - -#ifdef S_IRGRP - scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP)); -#endif -#ifdef S_IWGRP - scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP)); -#endif -#ifdef S_IXGRP - scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP)); -#endif -#ifdef S_IRWXG - scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG)); -#endif - -#ifdef S_IROTH - scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH)); -#endif -#ifdef S_IWOTH - scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH)); -#endif -#ifdef S_IXOTH - scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH)); -#endif -#ifdef S_IRWXO - scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO)); -#endif - -#ifdef S_ISUID - scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID)); -#endif -#ifdef S_ISGID - scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID)); -#endif -#ifdef S_ISVTX - scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX)); -#endif - -#ifdef S_IFMT - scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT)); -#endif -#ifdef S_IFDIR - scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR)); -#endif -#ifdef S_IFCHR - scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR)); -#endif -#ifdef S_IFBLK - scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK)); -#endif -#ifdef S_IFREG - scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG)); -#endif -#ifdef S_IFLNK - scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK)); -#endif -#ifdef S_IFSOCK - scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK)); -#endif -#ifdef S_IFIFO - scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO)); -#endif -#include "ioext.x" -} - diff --git a/libguile/ioext.h b/libguile/ioext.h deleted file mode 100644 index e026a1f23..000000000 --- a/libguile/ioext.h +++ /dev/null @@ -1,68 +0,0 @@ -/* classes: h_files */ - -#ifndef IOEXTH -#define IOEXTH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_sys_ftell SCM_P ((SCM port)); -extern SCM scm_sys_fseek SCM_P ((SCM port, SCM offset, SCM whence)); -extern SCM scm_sys_freopen SCM_P ((SCM filename, SCM modes, SCM port)); -extern SCM scm_sys_duplicate_port SCM_P ((SCM oldpt, SCM modes)); -extern SCM scm_sys_redirect_port SCM_P ((SCM into_pt, SCM from_pt)); -extern SCM scm_sys_fileno SCM_P ((SCM port)); -extern SCM scm_sys_isatty_p SCM_P ((SCM port)); -extern SCM scm_sys_fdopen SCM_P ((SCM fdes, SCM modes)); -extern SCM scm_sys_primitive_move_to_fdes SCM_P ((SCM port, SCM fd)); -extern void scm_setfileno SCM_P ((FILE *fs, int fd)); -extern void scm_evict_ports SCM_P ((int fd)); -extern SCM scm_fdes_to_ports SCM_P ((SCM fd)); -extern void scm_init_ioext SCM_P ((void)); - -#endif /* IOEXTH */ diff --git a/libguile/kw.c b/libguile/kw.c deleted file mode 100644 index 76ca88050..000000000 --- a/libguile/kw.c +++ /dev/null @@ -1,148 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "mbstrings.h" -#include "smob.h" - -#include "kw.h" - - - -static scm_sizet free_kw SCM_P ((SCM obj)); - -static scm_sizet -free_kw (obj) - SCM obj; -{ - return 0; -} - - -static int prin_kw SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prin_kw (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, ":", port); - scm_gen_puts((SCM_MB_STRINGP(SCM_CDR (exp)) - ? scm_mb_string - : scm_regular_string), - 1 + SCM_CHARS (SCM_CDR (exp)), - port); - return 1; -} - -int scm_tc16_kw; - -static scm_smobfuns kw_smob = {scm_markcdr, free_kw, prin_kw, 0}; - - - -SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol); - -SCM -scm_make_keyword_from_dash_symbol (symbol) - SCM symbol; -{ - SCM vcell; - - SCM_ASSERT (SCM_NIMP (symbol) && SCM_SYMBOLP(symbol) && ('-' == SCM_CHARS(symbol)[0]), - symbol, SCM_ARG1, s_make_keyword_from_dash_symbol); - - - SCM_DEFER_INTS; - vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray); - if (vcell == SCM_BOOL_F) - { - SCM kw; - SCM_NEWCELL(kw); - SCM_SETCAR (kw, (SCM)scm_tc16_kw); - SCM_SETCDR (kw, symbol); - scm_intern_symbol (scm_kw_obarray, symbol); - vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray); - SCM_SETCDR (vcell, kw); - } - SCM_ALLOW_INTS; - return SCM_CDR (vcell); -} - -SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p); - -SCM -scm_keyword_p (obj) - SCM obj; -{ - return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - -SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol); - -SCM -scm_keyword_dash_symbol (kw) - SCM kw; -{ - SCM_ASSERT (SCM_NIMP (kw) && SCM_KEYWORDP (kw), kw, SCM_ARG1, s_keyword_dash_symbol); - return SCM_CDR (kw); -} - - - - - -void -scm_init_kw () -{ - scm_tc16_kw = scm_newsmob (&kw_smob); - scm_kw_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL, SCM_UNDEFINED); -#include "kw.x" -} - diff --git a/libguile/kw.h b/libguile/kw.h deleted file mode 100644 index 89387c5b3..000000000 --- a/libguile/kw.h +++ /dev/null @@ -1,63 +0,0 @@ -/* classes: h_files */ - -#ifndef KWH -#define KWH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern int scm_tc16_kw; -#define SCM_KEYWORDP(X) (SCM_CAR(X) == scm_tc16_kw) -#define SCM_KEYWORDSYM(X) (SCM_CDR(X)) - - - - -extern SCM scm_make_keyword_from_dash_symbol SCM_P ((SCM symbol)); -extern SCM scm_keyword_p SCM_P ((SCM obj)); -extern SCM scm_keyword_dash_symbol SCM_P ((SCM kw)); -extern void scm_init_kw SCM_P ((void)); - -#endif /* KWH */ diff --git a/libguile/libguile.h b/libguile/libguile.h deleted file mode 100644 index 448d2de0a..000000000 --- a/libguile/libguile.h +++ /dev/null @@ -1,131 +0,0 @@ -#ifndef LIBGUILEH -#define LIBGUILEH - -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - -#include "libguile/__scm.h" - -/* These files define typedefs used by later files, so they need to - come first. */ -#include "libguile/print.h" -#include "libguile/smob.h" -#include "libguile/pairs.h" - -#include "libguile/alist.h" -#include "libguile/append.h" -#include "libguile/arbiters.h" -#include "libguile/async.h" -#include "libguile/boolean.h" -#include "libguile/chars.h" -#include "libguile/continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "libguile/backtrace.h" -#include "libguile/debug.h" -#include "libguile/stacks.h" -#endif -#include "libguile/dynwind.h" -#include "libguile/eq.h" -#include "libguile/error.h" -#include "libguile/eval.h" -#include "libguile/extchrs.h" -#include "libguile/fdsocket.h" -#include "libguile/feature.h" -#include "libguile/filesys.h" -#include "libguile/fports.h" -#include "libguile/gc.h" -#include "libguile/gdbint.h" -#include "libguile/genio.h" -#include "libguile/gsubr.h" -#include "libguile/hash.h" -#include "libguile/hashtab.h" -#include "libguile/init.h" -#include "libguile/ioext.h" -#include "libguile/kw.h" -#include "libguile/libpath.h" -#include "libguile/list.h" -#include "libguile/load.h" -#include "libguile/mallocs.h" -#include "libguile/markers.h" -#include "libguile/mbstrings.h" -#include "libguile/numbers.h" -#include "libguile/objprop.h" -#include "libguile/options.h" -#include "libguile/ports.h" -#include "libguile/posix.h" -#include "libguile/procprop.h" -#include "libguile/procs.h" -#include "libguile/ramap.h" -#include "libguile/read.h" -#include "libguile/root.h" -#include "libguile/scmsigs.h" -#include "libguile/sequences.h" -#include "libguile/simpos.h" -#include "libguile/snarf.h" -#include "libguile/socket.h" -#include "libguile/srcprop.h" -#include "libguile/stackchk.h" -#include "libguile/stime.h" -#include "libguile/strings.h" -#include "libguile/strop.h" -#include "libguile/strorder.h" -#include "libguile/strports.h" -#include "libguile/struct.h" -#include "libguile/symbols.h" -#include "libguile/tag.h" -#include "libguile/tags.h" -#include "libguile/throw.h" -#include "libguile/unif.h" -#include "libguile/variable.h" -#include "libguile/vectors.h" -#include "libguile/version.h" -#include "libguile/vports.h" -#include "libguile/weaks.h" -#ifdef USE_THREADS -#include "libguile/../threads/threads.h" -#endif - - - -#endif /* LIBGUILEH */ diff --git a/libguile/list.c b/libguile/list.c deleted file mode 100644 index 53f5da1fd..000000000 --- a/libguile/list.c +++ /dev/null @@ -1,655 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" - -#include "list.h" - -#ifdef __STDC__ -#include <stdarg.h> -#define var_start(x, y) va_start(x, y) -#else -#include <varargs.h> -#define var_start(x, y) va_start(x) -#endif - - -/* creating lists */ - -/* SCM_P won't help us deal with varargs here. */ -#ifdef __STDC__ -SCM -scm_listify (SCM elt, ...) -#else -SCM -scm_listify (elt, va_alist) - SCM elt; - va_dcl -#endif -{ - va_list foo; - SCM answer; - SCM *pos; - - var_start (foo, elt); - answer = SCM_EOL; - pos = &answer; - while (elt != SCM_UNDEFINED) - { - *pos = scm_cons (elt, SCM_EOL); - pos = SCM_CDRLOC (*pos); - elt = va_arg (foo, SCM); - } - return answer; -} - - -SCM_PROC(s_list, "list", 0, 0, 1, scm_list); -SCM -scm_list(objs) - SCM objs; -{ - return objs; -} - - - - -/* general questions about lists --- null?, list?, length, etc. */ - -SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p); -SCM -scm_null_p(x) - SCM x; -{ - return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p); -SCM -scm_list_p(x) - SCM x; -{ - if (scm_ilength(x)<0) - return SCM_BOOL_F; - else - return SCM_BOOL_T; -} - - -/* Return the length of SX, or -1 if it's not a proper list. - This uses the "tortoise and hare" algorithm to detect "infinitely - long" lists (i.e. lists with cycles in their cdrs), and returns -1 - if it does find one. */ -long -scm_ilength(sx) - SCM sx; -{ - register long i = 0; - register SCM tortoise = sx; - register SCM hare = sx; - - do { - if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1; - if SCM_NCONSP(hare) return -1; - hare = SCM_CDR(hare); - i++; - if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1; - if SCM_NCONSP(hare) return -1; - hare = SCM_CDR(hare); - i++; - /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); - } - while (hare != tortoise); - - /* If the tortoise ever catches the hare, then the list must contain - a cycle. */ - return -1; -} - -SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length); -SCM -scm_list_length(x) - SCM x; -{ - int i; - i = scm_ilength(x); - SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length); - return SCM_MAKINUM (i); -} - - - -/* appending lists */ - -SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append); -SCM -scm_list_append(args) - SCM args; -{ - SCM res = SCM_EOL; - SCM *lloc = &res, arg; - if SCM_IMP(args) { - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); - return res; - } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); - while (1) { - arg = SCM_CAR(args); - args = SCM_CDR(args); - if SCM_IMP(args) { - *lloc = arg; - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); - return res; - } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); - for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) { - SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append); - *lloc = scm_cons(SCM_CAR(arg), SCM_EOL); - lloc = SCM_CDRLOC(*lloc); - } - SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append); - } -} - - -SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x); -SCM -scm_list_append_x(args) - SCM args; -{ - SCM arg; - tail: - if SCM_NULLP(args) return SCM_EOL; - arg = SCM_CAR(args); - SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x); - args = SCM_CDR(args); - if SCM_NULLP(args) return arg; - if SCM_NULLP(arg) goto tail; - SCM_SETCDR (scm_last_pair (arg), scm_list_append_x (args)); - return arg; -} - - -SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); -SCM -scm_last_pair(sx) - SCM sx; -{ - register SCM res = sx; - register SCM x; - - if (SCM_NULLP (sx)) - return SCM_EOL; - - SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair); - while (!0) { - x = SCM_CDR(res); - if (SCM_IMP(x) || SCM_NCONSP(x)) return res; - res = x; - x = SCM_CDR(res); - if (SCM_IMP(x) || SCM_NCONSP(x)) return res; - res = x; - sx = SCM_CDR(sx); - SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair); - } -} - - -/* reversing lists */ - -SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse); -SCM -scm_list_reverse(lst) - SCM lst; -{ - SCM res = SCM_EOL; - SCM p = lst; - for(;SCM_NIMP(p);p = SCM_CDR(p)) { - SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse); - res = scm_cons(SCM_CAR(p), res); - } - SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse); - return res; -} - -SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x); -SCM -scm_list_reverse_x (lst, newtail) - SCM lst; - SCM newtail; -{ - SCM old_tail; - if (newtail == SCM_UNDEFINED) - newtail = SCM_EOL; - - loop: - if (!(SCM_NIMP (lst) && SCM_CONSP (lst))) - return lst; - - old_tail = SCM_CDR (lst); - SCM_SETCDR (lst, newtail); - if (SCM_NULLP (old_tail)) - return lst; - - newtail = lst; - lst = old_tail; - goto loop; -} - - - -/* indexing lists by element number */ - -SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref); -SCM -scm_list_ref(lst, k) - SCM lst; - SCM k; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref); - return SCM_CAR(lst); -} - -SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x); -SCM -scm_list_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x); - SCM_SETCAR (lst, val); - return val; -} - - -SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); -SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail); -SCM -scm_list_tail(lst, k) - SCM lst; - SCM k; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail); - i = SCM_INUM(k); - while (i-- > 0) { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail); - lst = SCM_CDR(lst); - } - return lst; -} - - -SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x); -SCM -scm_list_cdr_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x); - SCM_SETCDR (lst, val); - return val; -} - - - -/* copying lists, perhaps partially */ - -SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head); -SCM -scm_list_head(lst, k) - SCM lst; - SCM k; -{ - SCM answer; - SCM * pos; - register long i; - - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head); - answer = SCM_EOL; - pos = &answer; - i = SCM_INUM(k); - while (i-- > 0) - { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head); - *pos = scm_cons (SCM_CAR (lst), SCM_EOL); - pos = SCM_CDRLOC (*pos); - lst = SCM_CDR(lst); - } - return answer; -} - - -SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy); -SCM -scm_list_copy (lst) - SCM lst; -{ - SCM newlst; - SCM * fill_here; - SCM from_here; - - newlst = SCM_EOL; - fill_here = &newlst; - from_here = lst; - - while (SCM_NIMP (from_here) && SCM_CONSP (from_here)) - { - SCM c; - c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); - *fill_here = c; - fill_here = SCM_CDRLOC (c); - from_here = SCM_CDR (from_here); - } - return newlst; -} - - -/* membership tests (memq, memv, etc.) */ - -static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why)); - -static void -sloppy_mem_check (obj, where, why) - SCM obj; - char * where; - char * why; -{ - SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why); -} - - -SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq); -SCM -scm_sloppy_memq(x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_CAR(lst)==x) - return lst; - } - return lst; -} - - -SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv); -SCM -scm_sloppy_memv(x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x)) - return lst; - } - return lst; -} - - -SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member); -SCM -scm_sloppy_member (x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x)) - return lst; - } - return lst; -} - - - -SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq); -SCM -scm_memq(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_memq (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - - -SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv); -SCM -scm_memv(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_memv (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - -SCM_PROC(s_member, "member", 2, 0, 0, scm_member); -SCM -scm_member(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_member (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_member); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - - -/* deleting elements from a list (delq, etc.) */ - -SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x); -SCM -scm_delq_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_CAR (lst) == item) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_CAR (SCM_CDR (lst)) == item) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - -SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x); -SCM -scm_delv_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item)) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item)) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - - -SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x); -SCM -scm_delete_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item)) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item)) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - - - - -SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq); -SCM -scm_delq (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delq_x (item, copy); -} - -SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv); -SCM -scm_delv (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delv_x (item, copy); -} - -SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete); -SCM -scm_delete (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delete_x (item, copy); -} - - - -void -scm_init_list () -{ -#include "list.x" -} diff --git a/libguile/list.h b/libguile/list.h deleted file mode 100644 index 82d560673..000000000 --- a/libguile/list.h +++ /dev/null @@ -1,82 +0,0 @@ -/* classes: h_files */ - -#ifndef LISTH -#define LISTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern SCM scm_list_head SCM_P ((SCM lst, SCM k)); -extern SCM scm_listify SCM_P ((SCM elt, ...)); -extern SCM scm_list SCM_P ((SCM objs)); -extern SCM scm_null_p SCM_P ((SCM x)); -extern SCM scm_list_p SCM_P ((SCM x)); -extern long scm_ilength SCM_P ((SCM sx)); -extern SCM scm_list_length SCM_P ((SCM x)); -extern SCM scm_list_append SCM_P ((SCM args)); -extern SCM scm_list_append_x SCM_P ((SCM args)); -extern SCM scm_list_reverse SCM_P ((SCM lst)); -extern SCM scm_list_reverse_x SCM_P ((SCM lst, SCM newtail)); -extern SCM scm_list_ref SCM_P ((SCM lst, SCM k)); -extern SCM scm_list_set_x SCM_P ((SCM lst, SCM k, SCM val)); -extern SCM scm_list_cdr_ref SCM_P ((SCM lst, SCM k)); -extern SCM scm_list_cdr_set_x SCM_P ((SCM lst, SCM k, SCM val)); -extern SCM scm_last_pair SCM_P ((SCM sx)); -extern SCM scm_list_tail SCM_P ((SCM lst, SCM k)); -extern SCM scm_sloppy_memq SCM_P ((SCM x, SCM lst)); -extern SCM scm_sloppy_memv SCM_P ((SCM x, SCM lst)); -extern SCM scm_sloppy_member SCM_P ((SCM x, SCM lst)); -extern SCM scm_memq SCM_P ((SCM x, SCM lst)); -extern SCM scm_memv SCM_P ((SCM x, SCM lst)); -extern SCM scm_member SCM_P ((SCM x, SCM lst)); -extern SCM scm_delq_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_delv_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_delete_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_list_copy SCM_P ((SCM lst)); -extern SCM scm_delq SCM_P ((SCM item, SCM lst)); -extern SCM scm_delv SCM_P ((SCM item, SCM lst)); -extern SCM scm_delete SCM_P ((SCM item, SCM lst)); -extern void scm_init_list SCM_P ((void)); - -#endif /* LISTH */ diff --git a/libguile/load.c b/libguile/load.c deleted file mode 100644 index b9a9fc8cc..000000000 --- a/libguile/load.c +++ /dev/null @@ -1,343 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "libpath.h" -#include "fports.h" -#include "read.h" -#include "eval.h" -#include "throw.h" - -#include "load.h" - -#include <sys/types.h> -#include <sys/stat.h> - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif /* HAVE_UNISTD_H */ - -#ifndef R_OK -#define R_OK 4 -#endif - - -/* Loading a file, given an absolute filename. */ - -/* Hook to run when we load a file, perhaps to announce the fact somewhere. - Applied to the full name of the file. */ -static SCM *scm_loc_load_hook; - -SCM_PROC(s_primitive_load, "primitive-load", 1, 2, 0, scm_primitive_load); -SCM -scm_primitive_load (filename, case_insensitive_p, sharp) - SCM filename; - SCM case_insensitive_p; - SCM sharp; -{ - SCM hook = *scm_loc_load_hook; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load); - SCM_ASSERT (hook == SCM_BOOL_F - || (scm_procedure_p (hook) == SCM_BOOL_T), - hook, "value of %load-hook is neither a procedure nor #f", - s_primitive_load); - - if (hook != SCM_BOOL_F) - scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); - - { - SCM form, port; - port = scm_open_file (filename, - scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); - while (1) - { - form = scm_read (port, case_insensitive_p, sharp); - if (SCM_EOF_VAL == form) - break; - scm_eval_x (form); - } - scm_close_port (port); - } - return SCM_UNSPECIFIED; -} - - -/* Builtin path to scheme library files. */ -#ifdef SCM_PKGDATA_DIR -SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir); -SCM -scm_sys_package_data_dir () -{ - return scm_makfrom0str (SCM_PKGDATA_DIR); -} -#endif /* SCM_PKGDATA_DIR */ - - -/* Initializing the load path, and searching it. */ - -/* List of names of directories we search for files to load. */ -static SCM *scm_loc_load_path; - -/* List of extensions we try adding to the filenames. */ -static SCM *scm_loc_load_extensions; - -/* Initialize the global variable %load-path, given the value of the - SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the - SCHEME_LOAD_PATH environment variable. */ -void -scm_init_load_path () -{ - SCM path = SCM_EOL; - -#ifdef SCM_LIBRARY_DIR - path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - path); -#endif /* SCM_LIBRARY_DIR */ - - { - char *path_string = getenv ("SCHEME_LOAD_PATH"); - - if (path_string && path_string[0] != '\0') - { - char *scan, *elt_end; - - /* Scan backwards from the end of the string, to help - construct the list in the right order. */ - scan = elt_end = path_string + strlen (path_string); - do { - /* Scan back to the beginning of the current element. */ - do scan--; - while (scan >= path_string && *scan != ':'); - path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0), - path); - elt_end = scan; - } while (scan >= path_string); - } - } - - *scm_loc_load_path = path; -} - - -/* Search %load-path for a directory containing a file named FILENAME. - The file must be readable, and not a directory. - If we find one, return its full filename; otherwise, return #f. - If FILENAME is absolute, return it unchanged. */ -SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path); -SCM -scm_sys_search_load_path (filename) - SCM filename; -{ - SCM path = *scm_loc_load_path; - SCM exts = *scm_loc_load_extensions; - char *buf; - int filename_len; - int max_path_len; - int max_ext_len; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_sys_search_load_path); - SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", - s_sys_search_load_path); - SCM_ASSERT (scm_ilength (exts) >= 0, exts, - "load extension list is not a proper list", - s_sys_search_load_path); - filename_len = SCM_ROLENGTH (filename); - - /* If FILENAME is absolute, return it unchanged. */ - if (filename_len >= 1 - && SCM_ROCHARS (filename)[0] == '/') - return filename; - - /* Find the length of the longest element of path. */ - { - SCM walk; - - max_path_len = 0; - for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, - "load path is not a list of strings", - s_sys_search_load_path); - if (SCM_LENGTH (elt) > max_path_len) - max_path_len = SCM_LENGTH (elt); - } - } - - /* Find the length of the longest element of the load extensions - list. */ - { - SCM walk; - - max_ext_len = 0; - for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, - "load extension list is not a list of strings", - s_sys_search_load_path); - if (SCM_LENGTH (elt) > max_ext_len) - max_ext_len = SCM_LENGTH (elt); - } - } - - SCM_DEFER_INTS; - - buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1, - s_sys_search_load_path); - - /* Try every path element. At this point, we know it's a proper - list of strings. */ - for (; SCM_NIMP (path); path = SCM_CDR (path)) - { - SCM path_elt = SCM_CAR (path); - - /* Try every extension. At this point, we know it's a proper - list of strings. */ - for (exts = *scm_loc_load_extensions; - SCM_NIMP (exts); - exts = SCM_CDR (exts)) - { - SCM ext_elt = SCM_CAR (exts); - int i; - - /* Concatenate the path name, the filename, and the extension. */ - i = SCM_ROLENGTH (path_elt); - memcpy (buf, SCM_ROCHARS (path_elt), i); - if (i >= 1 && buf[i - 1] != '/') - buf[i++] = '/'; - memcpy (buf + i, SCM_ROCHARS (filename), filename_len); - i += filename_len; - memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt)); - i += SCM_LENGTH (ext_elt); - buf[i] = '\0'; - - { - struct stat mode; - - if (stat (buf, &mode) >= 0 - && ! (mode.st_mode & S_IFDIR) - && access (buf, R_OK) == 0) - { - SCM result = scm_makfromstr (buf, i, 0); - scm_must_free (buf); - SCM_ALLOW_INTS; - return result; - } - } - } - } - - scm_must_free (buf); - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 2, 0, scm_primitive_load_path); -SCM -scm_primitive_load_path (filename, case_insensitive_p, sharp) - SCM filename; - SCM case_insensitive_p; - SCM sharp; -{ - SCM full_filename; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load_path); - - full_filename = scm_sys_search_load_path (filename); - - if (SCM_FALSEP (full_filename)) - { - int absolute = (SCM_LENGTH (filename) >= 1 - && SCM_ROCHARS (filename)[0] == '/'); - scm_misc_error (s_primitive_load_path, - (absolute - ? "Unable to load file %S" - : "Unable to find file %S in load path"), - scm_listify (filename, SCM_UNDEFINED)); - } - - return scm_primitive_load (full_filename, case_insensitive_p, sharp); -} - -/* The following function seems trivial - and indeed it is. Its - * existence is motivated by its ability to evaluate expressions - * without copying them first (as is done in "eval"). - */ - -SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); - -SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 3, 0, scm_read_and_eval_x); - -SCM -scm_read_and_eval_x (port, case_insensitive_p, sharp) - SCM port; - SCM case_insensitive_p; - SCM sharp; -{ - SCM form = scm_read (port, case_insensitive_p, sharp); - if (form == SCM_EOF_VAL) - scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form); -} - - - -void -scm_init_load () -{ - scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL)); - scm_loc_load_extensions - = SCM_CDRLOC(scm_sysintern("%load-extensions", - scm_listify (scm_makfrom0str (""), - scm_makfrom0str (".scm"), - SCM_UNDEFINED))); - scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F)); - -#include "load.x" -} diff --git a/libguile/load.h b/libguile/load.h deleted file mode 100644 index cd5d021bb..000000000 --- a/libguile/load.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef LOADH -#define LOADH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern void scm_init_load_path SCM_P ((void)); -extern SCM scm_primitive_load SCM_P ((SCM filename, SCM casep, SCM sharp)); -extern SCM scm_sys_package_data_dir SCM_P ((void)); -extern SCM scm_sys_search_load_path SCM_P ((SCM filename)); -extern SCM scm_primitive_load_path SCM_P ((SCM filename, SCM casep, - SCM sharp)); -extern SCM scm_read_and_eval_x SCM_P ((SCM port, - SCM case_insensitive_p, - SCM sharp)); -extern void scm_init_load SCM_P ((void)); - -#endif /* LOADH */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c deleted file mode 100644 index 4201adca8..000000000 --- a/libguile/mallocs.c +++ /dev/null @@ -1,105 +0,0 @@ -/* classes: src_files */ - -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - */ - - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "mallocs.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - - - - -static scm_sizet fmalloc SCM_P ((SCM ptr)); - -static scm_sizet -fmalloc(ptr) - SCM ptr; -{ - if (SCM_MALLOCDATA (ptr)) - free (SCM_MALLOCDATA (ptr)); - return 0; -} - - -static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinmalloc (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts(scm_regular_string, "#<malloc ", port); - scm_intprint(SCM_CDR(exp), 16, port); - scm_gen_putc('>', port); - return 1; -} - - -int scm_tc16_malloc; -static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, prinmalloc, 0}; - - - - -SCM -scm_malloc_obj (n) - scm_sizet n; -{ - SCM answer; - SCM mem; - - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - mem = (n - ? (SCM)malloc (n) - : 0); - if (n && !mem) - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - SCM_SETCDR (answer, mem); - SCM_SETCAR (answer, scm_tc16_malloc); - SCM_ALLOW_INTS; - return answer; -} - - - - -void -scm_init_mallocs () -{ - scm_tc16_malloc = scm_newsmob (&mallocsmob); -} - diff --git a/libguile/mallocs.h b/libguile/mallocs.h deleted file mode 100644 index 19fa8e5cd..000000000 --- a/libguile/mallocs.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef MALLOCSH -#define MALLOCSH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern int scm_tc16_malloc; - -#define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc) -#define SCM_MALLOCDATA(obj) ((char *)SCM_CDR(obj)) -#define SCM_SETMALLOCDATA(obj, val) ((char *)SCM_SETCDR(obj, val)) - - - -extern SCM scm_malloc_obj SCM_P ((scm_sizet n)); -extern void scm_init_mallocs SCM_P ((void)); - -#endif /* MALLOCSH */ diff --git a/libguile/markers.c b/libguile/markers.c deleted file mode 100644 index 2736b0df5..000000000 --- a/libguile/markers.c +++ /dev/null @@ -1,81 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "markers.h" - - -/* {GC marking} - */ - - -SCM -scm_mark0 (ptr) - SCM ptr; -{ - SCM_SETGC8MARK (ptr); - return SCM_BOOL_F; -} - - - -SCM -scm_markcdr (ptr) - SCM ptr; -{ - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_CDR (ptr); -} - - -scm_sizet -scm_free0 (ptr) - SCM ptr; -{ - return 0; -} - - diff --git a/libguile/markers.h b/libguile/markers.h deleted file mode 100644 index 6a80e61a2..000000000 --- a/libguile/markers.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef MARKERSH -#define MARKERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_mark0 SCM_P ((SCM ptr)); -extern SCM scm_markcdr SCM_P ((SCM ptr)); -extern scm_sizet scm_free0 SCM_P ((SCM ptr)); - -#endif /* MARKERSH */ diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c deleted file mode 100644 index 41e04bf80..000000000 --- a/libguile/mbstrings.c +++ /dev/null @@ -1,505 +0,0 @@ - - -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "unif.h" -#include "genio.h" -#include "read.h" - -#include "mbstrings.h" - - -SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p); - -SCM -scm_multi_byte_string_p (obj) - SCM obj; -{ - return (SCM_MB_STRINGP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - -SCM -scm_regular_string_p (obj) - SCM obj; -{ - return (SCM_REGULAR_STRINGP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_list_to_multi_byte_string, "list->multi-byte-string", 1, 0, 0, scm_multi_byte_string); -SCM_PROC(s_multi_byte_string, "multi-byte-string", 0, 0, 1, scm_multi_byte_string); - -SCM -scm_multi_byte_string (chrs) - SCM chrs; -{ - SCM res; - register char *data; - long i; - long byte_len; - - i = scm_ilength (chrs); - SCM_ASSERT (i >= 0, chrs, SCM_ARG1, s_multi_byte_string); - i = i * XMB_CUR_MAX; - res = scm_makstr (i, 0); - SCM_SETLENGTH (res, SCM_LENGTH (res), scm_tc7_mb_string); - data = SCM_CHARS (res); - byte_len = 0; - xwctomb (0, 0); - while (i && SCM_NNULLP (chrs)) - { - int used; - SCM ch; - - ch = SCM_CAR (chrs); - SCM_ASSERT (SCM_ICHRP (ch), chrs, SCM_ARG1, s_multi_byte_string); - used = xwctomb (data + byte_len, SCM_ICHR (ch)); - SCM_ASSERT (used >= 0, chrs, SCM_ARG1, s_multi_byte_string); - byte_len += (used ? used : 1); - chrs = SCM_CDR (chrs); - --i; - } - res = scm_vector_set_length_x (res, SCM_MAKINUM (byte_len)); - return res; -} - - -int -scm_mb_ilength (data, size) - unsigned char * data; - int size; -{ - int pos; - int len; - - len = 0; - pos = 0; - xmblen (0, 0); - while (pos < size) - { - int inc; - - inc = xmblen (data + pos, size - pos); - if (inc == 0) - ++inc; - - if (inc < 0) - return -1; - - ++len; - pos += inc; - } - - return len; -} - -SCM_PROC(s_multi_byte_string_length, "multi-byte-string-length", 1, 0, 0, scm_multi_byte_string_length); - -SCM -scm_multi_byte_string_length (str) - SCM str; -{ - int size; - int len; - unsigned char * data; - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_multi_byte_string_length); - - data = SCM_ROCHARS (str); - size = SCM_ROLENGTH (str); - len = scm_mb_ilength (data, size); - SCM_ASSERT (len >= 0, str, SCM_ARG1, s_multi_byte_string_length); - return SCM_MAKINUM (len); -} - - -SCM_PROC(s_symbol_multi_byte_p, "symbol-multi-byte?", 1, 0, 0, scm_symbol_multi_byte_p); - -SCM -scm_symbol_multi_byte_p (symbol) - SCM symbol; -{ - return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol); -} - -SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x); - -SCM -scm_set_symbol_multi_byte_x (symbol, val) - SCM symbol; - SCM val; -{ - if (SCM_TYP7 (symbol) == scm_tc7_msymbol) - { - SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val) - ? SCM_BOOL_F - : SCM_BOOL_T); - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_regular_port_p, "regular-port?", 1, 0, 0, scm_regular_port_p); - -SCM -scm_regular_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_regular_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_regular_port_x, "regular-port!", 1, 0, 0, scm_regular_port_x); - -SCM -scm_regular_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_regular_port; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_multi_byte_port_p, "multi-byte-port?", 1, 0, 0, scm_multi_byte_port_p); - -SCM -scm_multi_byte_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_mb_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_multi_byte_port_x, "multi-byte-port!", 1, 0, 0, scm_multi_byte_port_x); - -SCM -scm_multi_byte_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_mb_port; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_wide_character_port_p, "wide-character-port?", 1, 0, 0, scm_wide_character_port_p); - -SCM -scm_wide_character_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_wchar_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_wide_character_port_x, "wide-character-port!", 1, 0, 0, scm_wide_character_port_x); - -SCM -scm_wide_character_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_wchar_port; - return SCM_UNSPECIFIED; -} - - - - - - -void -scm_put_wchar (c, port, writing) - int c; - SCM port; - int writing; -{ - if (writing) - scm_gen_puts (scm_regular_string, "#\\", port); - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - { - if (c < 256) - { - if (!writing) - scm_gen_putc ((unsigned char)c, port); - else if ((c <= ' ') && scm_charnames[c]) - scm_gen_puts (scm_regular_string, scm_charnames[c], port); - else if (c > '\177') - scm_intprint (c, 8, port); - else - scm_gen_putc ((int) c, port); - } - else - { - print_octal: - if (!writing) - scm_gen_putc ('\\', port); - scm_intprint (c, 8, port); - } - break; - } - - case scm_mb_port: - { - char buf[256]; - int len; - - if (XMB_CUR_MAX > sizeof (buf)) - goto print_octal; - - len = xwctomb (buf, c); - - if (len < 0) - goto print_octal; - - if (len == 0) - scm_gen_putc (0, port); - else - scm_gen_putc (c, port); - break; - } - - case scm_wchar_port: - { - scm_gen_putc (c, port); - break; - } - } -} - - - - - - -void -scm_print_mb_string (exp, port, writing) - SCM exp; - SCM port; - int writing; -{ - if (writing) - { - int i; - int len; - char * data; - - scm_gen_putc ('\"', port); - i = 0; - len = SCM_ROLENGTH (exp); - data = SCM_ROCHARS (exp); - - while (i < len) - { - xwchar_t c; - int inc; - - inc = xmbtowc (&c, data + i, len - i); - if (inc == 0) - inc = 1; - if (inc < 0) - { - inc = 1; - c = data[i]; - } - i += inc; - switch (c) - { - case '\"': - case '\\': - scm_gen_putc ('\\', port); - default: - scm_gen_putc (c, port); - } - } - scm_gen_putc ('\"', port); - } - else - scm_gen_write (scm_mb_string, SCM_ROCHARS (exp), SCM_ROLENGTH (exp), port); -} - - - -void -scm_print_mb_symbol (exp, port) - SCM exp; - SCM port; -{ - int pos; - int end; - int len; - char * str; - int weird; - int maybe_weird; - int mw_pos = 0; /* initialized to placate compiler */ - int inc = 0; /* same */ - xwchar_t c; - - len = SCM_LENGTH (exp); - str = SCM_CHARS (exp); - scm_remember (&exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - for (end = pos; end < len; end += inc) - { - inc = xmbtowc (&c, str + end, len - end); - if (inc < 0) - { - inc = 1; - c = str[end]; - goto weird_handler; - } - if (inc == 0) - { - inc = 1; - goto weird_handler; - } - switch (c) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '\"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_gen_write (scm_regular_string, "#{", 2, port); - weird = 1; - } - if (pos < end) - { - int q; - int qinc; - - q = pos; - while (q < end) - { - qinc = xmbtowc (&c, str + q, end - q); - if (inc <= 0) - { - inc = 1; - c = str[q]; - } - scm_gen_putc (c, port); - q += qinc; - } - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_gen_write (scm_regular_string, buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - } - if (pos < end) - { - int q; - int qinc; - q = pos; - while (q < end) - { - qinc = xmbtowc (&c, str + q, end - q); - if (inc <= 0) - inc = 1; - scm_gen_putc (c, port); - q += qinc; - } - } - if (weird) - scm_gen_write (scm_regular_string, "}#", 2, port); -} - - - - - -void -scm_init_mbstrings () -{ -#include "mbstrings.x" -} - diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h deleted file mode 100644 index 84482c5a8..000000000 --- a/libguile/mbstrings.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef MBSTRINGSH -#define MBSTRINGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" -#include "libguile/symbols.h" - - -#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \ - || ( (SCM_TYP7(x) == scm_tc7_msymbol) \ - && (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F))) -#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string) - - - - - -extern SCM scm_multi_byte_string_p SCM_P ((SCM obj)); -extern SCM scm_regular_string_p SCM_P ((SCM obj)); -extern SCM scm_multi_byte_string SCM_P ((SCM chrs)); -extern int scm_mb_ilength SCM_P ((unsigned char * data, int size)); -extern SCM scm_multi_byte_string_length SCM_P ((SCM str)); -extern SCM scm_symbol_multi_byte_p SCM_P ((SCM symbol)); -extern SCM scm_set_symbol_multi_byte_x SCM_P ((SCM symbol, SCM val)); -extern SCM scm_regular_port_p SCM_P ((SCM p)); -extern SCM scm_regular_port_x SCM_P ((SCM p)); -extern SCM scm_multi_byte_port_p SCM_P ((SCM p)); -extern SCM scm_multi_byte_port_x SCM_P ((SCM p)); -extern SCM scm_wide_character_port_p SCM_P ((SCM p)); -extern SCM scm_wide_character_port_x SCM_P ((SCM p)); -extern void scm_put_wchar SCM_P ((int c, SCM port, int writing)); -extern void scm_print_mb_string SCM_P ((SCM exp, SCM port, int writing)); -extern void scm_print_mb_symbol SCM_P ((SCM exp, SCM port)); -extern void scm_init_mbstrings SCM_P ((void)); - -#endif /* MBSTRINGSH */ diff --git a/libguile/numbers.c b/libguile/numbers.c deleted file mode 100644 index 360527611..000000000 --- a/libguile/numbers.c +++ /dev/null @@ -1,3704 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <math.h> -#include "_scm.h" -#include "genio.h" -#include "unif.h" - -#include "numbers.h" - -#define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' - - -/* IS_INF tests its floating point number for infiniteness - */ -#ifndef IS_INF -# define IS_INF(x) ((x)==(x)/2) -#endif - -/* MAXEXP is the maximum double precision expontent - * FLTMAX is less than or scm_equal the largest single precision float - */ - -#ifdef SCM_FLOATS -# ifdef STDC_HEADERS -# ifndef GO32 -# include <float.h> -# endif /* ndef GO32 */ -# endif /* def STDC_HEADERS */ -# ifdef DBL_MAX_10_EXP -# define MAXEXP DBL_MAX_10_EXP -# else -# define MAXEXP 308 /* IEEE doubles */ -# endif /* def DBL_MAX_10_EXP */ -# ifdef FLT_MAX -# define FLTMAX FLT_MAX -# else -# define FLTMAX 1e+23 -# endif /* def FLT_MAX */ -#endif /* def SCM_FLOATS */ - - - -SCM_PROC(s_exact_p, "exact?", 1, 0, 0, scm_exact_p); - -SCM -scm_exact_p(x) - SCM x; -{ - if SCM_INUMP(x) return SCM_BOOL_T; -#ifdef SCM_BIGDIG - if (SCM_NIMP(x) && SCM_BIGP(x)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - -SCM_PROC(s_odd_p, "odd?", 1, 0, 0, scm_odd_p); - -SCM -scm_odd_p(n) - SCM n; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_odd_p); - return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_odd_p); -#endif - return (4 & (int)n) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_even_p, "even?", 1, 0, 0, scm_even_p); - -SCM -scm_even_p(n) - SCM n; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_even_p); - return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_F : SCM_BOOL_T; - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_even_p); -#endif - return (4 & (int)n) ? SCM_BOOL_F : SCM_BOOL_T; -} - -SCM_PROC(s_abs, "abs", 1, 0, 0, scm_abs); - -SCM -scm_abs(x) - SCM x; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_abs); - if (SCM_TYP16(x)==scm_tc16_bigpos) return x; - return scm_copybig(x, 0); - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_abs); -#endif - if (SCM_INUM(x) >= 0) return x; - x = -SCM_INUM(x); - if (!SCM_POSFIXABLE(x)) -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else - scm_num_overflow (s_abs); -#endif - return SCM_MAKINUM(x); -} - -SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient); - -SCM -scm_quotient(x, y) - SCM x; - SCM y; -{ - register long z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - long w; - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_quotient); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), - SCM_NUMDIGS(x), - SCM_BDIGITS(y), - SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), - 2); - } - z = SCM_INUM(y); - SCM_ASRTGO(z, ov); - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z); - return scm_normbig(w); - } -#ifndef SCM_DIGSTOOBIG - w = scm_pseudolong(z); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&w, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 2); -#else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 2); - } -#endif - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_quotient); -# endif - return SCM_INUM0; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_quotient); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_quotient); -#endif - if ((z = SCM_INUM(y))==0) - ov: scm_num_overflow (s_quotient); - z = SCM_INUM(x)/z; -#ifdef BADIVSGNS - { -#if (__TURBOC__==1) - long t = ((y<0) ? -SCM_INUM(x) : SCM_INUM(x))%SCM_INUM(y); -#else - long t = SCM_INUM(x)%SCM_INUM(y); -#endif - if (t==0) ; - else if (t < 0) - if (x < 0) ; - else z--; - else if (x < 0) z++; - } -#endif - if (!SCM_FIXABLE(z)) -#ifdef SCM_BIGDIG - return scm_long2big(z); -#else - scm_num_overflow (s_quotient); -#endif - return SCM_MAKINUM(z); -} - -SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder); - -SCM -scm_remainder(x, y) - SCM x; - SCM y; -{ - register long z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_remainder); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x), 0); - } - if (!(z = SCM_INUM(y))) goto ov; - return scm_divbigint(x, z, SCM_BIGSIGN(x), 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_remainder); -# endif - return x; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_remainder); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_remainder); -#endif - if (!(z = SCM_INUM(y))) - ov: scm_num_overflow (s_remainder); -#if (__TURBOC__==1) - if (z < 0) z = -z; -#endif - z = SCM_INUM(x)%z; -#ifdef BADIVSGNS - if (!z) ; - else if (z < 0) - if (x < 0) ; - else z += SCM_INUM(y); - else if (x < 0) z -= SCM_INUM(y); -#endif - return SCM_MAKINUM(z); -} - -SCM_PROC(s_modulo, "modulo", 2, 0, 0, scm_modulo); - -SCM -scm_modulo(x, y) - SCM x; - SCM y; -{ - register long yy, z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_modulo); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y), (SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)) ? 1 : 0); - } - if (!(z = SCM_INUM(y))) goto ov; - return scm_divbigint(x, z, y < 0, (SCM_BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_modulo); -# endif - return (SCM_BIGSIGN(y) ? (x>0) : (x<0)) ? scm_sum(x, y) : x; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_modulo); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_modulo); -#endif - if (!(yy = SCM_INUM(y))) - ov: scm_num_overflow (s_modulo); -#if (__TURBOC__==1) - z = SCM_INUM(x); - z = ((yy<0) ? -z : z)%yy; -#else - z = SCM_INUM(x)%yy; -#endif - return SCM_MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z); -} - -SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd); - -SCM -scm_gcd(x, y) - SCM x; - SCM y; -{ - register long u, v, k, t; - if SCM_UNBNDP(y) return SCM_UNBNDP(x) ? SCM_INUM0 : x; - tailrec: -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - big_gcd: - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_gcd); - if SCM_BIGSIGN(x) x = scm_copybig(x, 0); - newy: - if SCM_NINUMP(y) { - SCM_ASSERT(SCM_NIMP(y) && SCM_BIGP(y), y, SCM_ARG2, s_gcd); - if SCM_BIGSIGN(y) y = scm_copybig(y, 0); - switch (scm_bigcomp(x, y)) { - case -1: - swaprec: t = scm_remainder(x, y); x = y; y = t; goto tailrec; - case 0: return x; - case 1: y = scm_remainder(y, x); goto newy; - } - /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */ - } - if (SCM_INUM0==y) return x; goto swaprec; - } - if SCM_NINUMP(y) { t=x; x=y; y=t; goto big_gcd;} -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_gcd); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_gcd); -#endif - u = SCM_INUM(x); - if (u<0) u = -u; - v = SCM_INUM(y); - if (v<0) v = -v; - else if (0==v) goto getout; - if (0==u) {u = v; goto getout;} - for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1); - if (1 & (int)u) t = -v; - else { - t = u; - b3: - t = SCM_SRS(t, 1); - } - if (!(1 & (int)t)) goto b3; - if (t>0) u = t; - else v = -t; - if ((t = u-v)) goto b3; - u = u*k; - getout: - if (!SCM_POSFIXABLE(u)) -#ifdef SCM_BIGDIG - return scm_long2big(u); -#else - scm_num_overflow (s_gcd); -#endif - return SCM_MAKINUM(u); -} - -SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm); - -SCM -scm_lcm(n1, n2) - SCM n1; - SCM n2; -{ - SCM d; - if SCM_UNBNDP(n2) { - n2 = SCM_MAKINUM(1L); - if SCM_UNBNDP(n1) return n2; - } - d = scm_gcd(n1, n2); - if (SCM_INUM0==d) return d; - return scm_abs(scm_product(n1, scm_quotient(n2, d))); -} - -#ifndef SCM_BIGDIG -# ifndef SCM_FLOATS -# define scm_long2num SCM_MAKINUM -# endif -#endif - -#ifndef scm_long2num -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logand) - & scm_num2long(n2, (char *)SCM_ARG2, s_logand)); -} - -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logior) - | scm_num2long(n2, (char *)SCM_ARG2, s_logior)); -} - -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logxor) - ^ scm_num2long(n2, (char *)SCM_ARG2, s_logxor)); -} - -SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest(n1, n2) - SCM n1; - SCM n2; -{ - return ((scm_num2long (n1, (char *)SCM_ARG1, s_logtest) - & scm_num2long (n2, (char *)SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); -} - - -SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p(n1, n2) - SCM n1; - SCM n2; -{ - return (((1 << scm_num2long (n1, (char *)SCM_ARG1, s_logtest)) - & scm_num2long (n2, (char *)SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); -} - -#else - -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logand); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logand); - return SCM_MAKINUM(SCM_INUM(n1) & SCM_INUM(n2)); -} - -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logior); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logior); - return SCM_MAKINUM(SCM_INUM(n1) | SCM_INUM(n2)); -} - -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logxor); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logxor); - return SCM_MAKINUM(SCM_INUM(n1) ^ SCM_INUM(n2)); -} - -SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logtest); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logtest); - return (SCM_INUM(n1) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1) && SCM_INUM(n1) >= 0, n1, SCM_ARG1, s_logbit_p); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logbit_p); - return ((1 << SCM_INUM(n1)) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F; -} -#endif - -SCM_PROC(s_lognot, "lognot", 1, 0, 0, scm_lognot); - -SCM -scm_lognot(n) - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_lognot); - return scm_difference(SCM_MAKINUM(-1L), n); -} - -SCM_PROC(s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt); - -SCM -scm_integer_expt(z1, z2) - SCM z1; - SCM z2; -{ - SCM acc = SCM_MAKINUM(1L); -#ifdef SCM_BIGDIG - if (SCM_INUM0==z1 || acc==z1) return z1; - else if (SCM_MAKINUM(-1L)==z1) return SCM_BOOL_F==scm_even_p(z2)?z1:acc; -#endif - SCM_ASSERT(SCM_INUMP(z2), z2, SCM_ARG2, s_integer_expt); - z2 = SCM_INUM(z2); - if (z2 < 0) { - z2 = -z2; - z1 = scm_divide(z1, SCM_UNDEFINED); - } - while(1) { - if (0==z2) return acc; - if (1==z2) return scm_product(acc, z1); - if (z2 & 1) acc = scm_product(acc, z1); - z1 = scm_product(z1, z1); - z2 >>= 1; - } -} - -SCM_PROC(s_ash, "ash", 2, 0, 0, scm_ash); - -SCM -scm_ash(n, cnt) - SCM n; - SCM cnt; -{ - SCM res = SCM_INUM(n); - SCM_ASSERT(SCM_INUMP(cnt), cnt, SCM_ARG2, s_ash); -#ifdef SCM_BIGDIG - if(cnt < 0) { - res = scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt))); - if (SCM_NFALSEP(scm_negative_p(n))) - return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n), res)); - else return scm_quotient(n, res); - } - else return scm_product(n, scm_integer_expt(SCM_MAKINUM(2), cnt)); -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_ash); - cnt = SCM_INUM(cnt); - if (cnt < 0) return SCM_MAKINUM(SCM_SRS(res, -cnt)); - res = SCM_MAKINUM(res<<cnt); - if (SCM_INUM(res)>>cnt != SCM_INUM(n)) - scm_num_overflow (s_ash); - return res; -#endif -} - -SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract); - -SCM -scm_bit_extract(n, start, end) - SCM n; - SCM start; - SCM end; -{ - SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG2, s_bit_extract); - SCM_ASSERT(SCM_INUMP(end), end, SCM_ARG3, s_bit_extract); - start = SCM_INUM(start); end = SCM_INUM(end); - SCM_ASSERT(end >= start, SCM_MAKINUM(end), SCM_OUTOFRANGE, s_bit_extract); -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) - return - scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end - start)), - SCM_MAKINUM(1L)), - scm_ash(n, SCM_MAKINUM(-start))); -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_bit_extract); -#endif - return SCM_MAKINUM((SCM_INUM(n)>>start) & ((1L<<(end-start))-1)); -} - -char scm_logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; -SCM_PROC(s_logcount, "logcount", 1, 0, 0, scm_logcount); - -SCM -scm_logcount(n) - SCM n; -{ - register unsigned long c = 0; - register long nn; -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - scm_sizet i; SCM_BIGDIG *ds, d; - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_logcount); - if SCM_BIGSIGN(n) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n)); - ds = SCM_BDIGITS(n); - for(i = SCM_NUMDIGS(n); i--; ) - for(d = ds[i]; d; d >>= 4) c += scm_logtab[15 & d]; - return SCM_MAKINUM(c); - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_logcount); -#endif - if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn; - for(; nn; nn >>= 4) c += scm_logtab[15 & nn]; - return SCM_MAKINUM(c); -} - -char scm_ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4}; -SCM_PROC(s_integer_length, "integer-length", 1, 0, 0, scm_integer_length); - -SCM -scm_integer_length(n) - SCM n; -{ - register unsigned long c = 0; - register long nn; - unsigned int l = 4; -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_BIGDIG *ds, d; - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_integer_length); - if SCM_BIGSIGN(n) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n)); - ds = SCM_BDIGITS(n); - d = ds[c = SCM_NUMDIGS(n)-1]; - for(c *= SCM_BITSPERDIG; d; d >>= 4) {c += 4; l = scm_ilentab[15 & d];} - return SCM_MAKINUM(c - 4 + l); - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_integer_length); -#endif - if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn; - for(;nn; nn >>= 4) {c += 4; l = scm_ilentab[15 & nn];} - return SCM_MAKINUM(c - 4 + l); -} - - -#ifdef SCM_BIGDIG -char s_bignum[] = "bignum"; - -SCM -scm_mkbig(nlen, sign) - scm_sizet nlen; - int sign; -{ - SCM v = nlen; - if (((v << 16) >> 16) != nlen) - scm_wta(SCM_MAKINUM(nlen), (char *)SCM_NALLOC, s_bignum); - SCM_NEWCELL(v); - SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc((long)(nlen*sizeof(SCM_BIGDIG)), s_bignum)); - SCM_SETNUMDIGS(v, nlen, sign?scm_tc16_bigneg:scm_tc16_bigpos); - SCM_ALLOW_INTS; - return v; -} - - -SCM -scm_big2inum(b, l) - SCM b; - scm_sizet l; -{ - unsigned long num = 0; - SCM_BIGDIG *tmp = SCM_BDIGITS(b); - while (l--) num = SCM_BIGUP(num) + tmp[l]; - if (SCM_TYP16(b)==scm_tc16_bigpos) { - if SCM_POSFIXABLE(num) return SCM_MAKINUM(num); - } - else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num); - return b; -} - - -char s_adjbig[] = "scm_adjbig"; - -SCM -scm_adjbig(b, nlen) - SCM b; - scm_sizet nlen; -{ - long nsiz = nlen; - if (((nsiz << 16) >> 16) != nlen) scm_wta(SCM_MAKINUM(nsiz), (char *)SCM_NALLOC, s_adjbig); - SCM_DEFER_INTS; - SCM_SETCHARS(b, (SCM_BIGDIG *)scm_must_realloc((char *)SCM_CHARS(b), - (long)(SCM_NUMDIGS(b)*sizeof(SCM_BIGDIG)), - (long)(nsiz*sizeof(SCM_BIGDIG)), s_adjbig)); - SCM_SETNUMDIGS(b, nsiz, SCM_TYP16(b)); - SCM_ALLOW_INTS; - return b; -} - - - -SCM -scm_normbig(b) - SCM b; -{ -#ifndef _UNICOS - scm_sizet nlen = SCM_NUMDIGS(b); -#else - int nlen = SCM_NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */ -#endif - SCM_BIGDIG *zds = SCM_BDIGITS(b); - while (nlen-- && !zds[nlen]); nlen++; - if (nlen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM)) - if SCM_INUMP(b = scm_big2inum(b, (scm_sizet)nlen)) return b; - if (SCM_NUMDIGS(b)==nlen) return b; - return scm_adjbig(b, (scm_sizet)nlen); -} - - - -SCM -scm_copybig(b, sign) - SCM b; - int sign; -{ - scm_sizet i = SCM_NUMDIGS(b); - SCM ans = scm_mkbig(i, sign); - SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans); - while (i--) dst[i] = src[i]; - return ans; -} - - - -SCM -scm_long2big(n) - long n; -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig(SCM_DIGSPERLONG, n<0); - digits = SCM_BDIGITS(ans); - if (n < 0) n = -n; - while (i < SCM_DIGSPERLONG) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - return ans; -} - -#ifdef LONGLONGS - -SCM -scm_long_long2big(n) - long_long n; -{ - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - int n_digits; - - { - long tn; - tn = (long) n; - if ((long long)tn == n) - return scm_long2big (tn); - } - - { - long_long tn; - - for (tn = n, n_digits = 0; - tn; - ++n_digits, tn = SCM_BIGDN ((ulong_long)tn)) - ; - } - - i = 0; - ans = scm_mkbig(n_digits, n<0); - digits = SCM_BDIGITS(ans); - if (n < 0) - n = -n; - while (i < n_digits) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN((ulong_long)n); - } - return ans; -} -#endif - - -SCM -scm_2ulong2big(np) - unsigned long * np; -{ - unsigned long n; - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - - ans = scm_mkbig(2 * SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS(ans); - - n = np[0]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - n = np[1]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i + SCM_DIGSPERLONG] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - return ans; -} - - - -SCM -scm_ulong2big(n) - unsigned long n; -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig(SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS(ans); - while (i < SCM_DIGSPERLONG) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN(n); - } - return ans; -} - - - -int -scm_bigcomp(x, y) - SCM x; - SCM y; -{ - int xsign = SCM_BIGSIGN(x); - int ysign = SCM_BIGSIGN(y); - scm_sizet xlen, ylen; - if (ysign < xsign) return 1; - if (ysign > xsign) return -1; - if ((ylen = SCM_NUMDIGS(y)) > (xlen = SCM_NUMDIGS(x))) return (xsign) ? -1 : 1; - if (ylen < xlen) return (xsign) ? 1 : -1; - while(xlen-- && (SCM_BDIGITS(y)[xlen]==SCM_BDIGITS(x)[xlen])); - if (-1==xlen) return 0; - return (SCM_BDIGITS(y)[xlen] > SCM_BDIGITS(x)[xlen]) ? - (xsign ? -1 : 1) : (xsign ? 1 : -1); -} - -#ifndef SCM_DIGSTOOBIG - - -long -scm_pseudolong(x) - long x; -{ - union { - long l; - SCM_BIGDIG bd[SCM_DIGSPERLONG]; - } p; - scm_sizet i = 0; - if (x < 0) x = -x; - while (i < SCM_DIGSPERLONG) {p.bd[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);} - /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */ - return p.l; -} - -#else - - -void -scm_longdigs(x, digs) - long x; - SCM_BIGDIG digs[]; -{ - scm_sizet i = 0; - if (x < 0) x = -x; - while (i < SCM_DIGSPERLONG) {digs[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);} -} -#endif - - - -SCM -scm_addbig(x, nx, xsgn, bigy, sgny) - SCM_BIGDIG *x; - scm_sizet nx; - int xsgn; - SCM bigy; - int sgny; -{ - /* Assumes nx <= SCM_NUMDIGS(bigy) */ - /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */ - long num = 0; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); - SCM z = scm_copybig(bigy, SCM_BIGSIGN(bigy) ^ sgny); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - if (xsgn ^ SCM_BIGSIGN(z)) { - do { - num += (long) zds[i] - x[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = SCM_BIGLO(num); num = 0;} - } while (++i < nx); - if (num && nx==ny) { - num = 1; i = 0; - SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100); - do { - num += (SCM_BIGRAD-1) - zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (i < ny); - } - else while (i < ny) { - num += zds[i]; - if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;} - else {zds[i++] = SCM_BIGLO(num); num = 0;} - } - } else { - do { - num += (long) zds[i] + x[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (i < nx); - if (!num) return z; - while (i < ny) { - num += zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - if (!num) return z; - } - if (num) {z = scm_adjbig(z, ny+1); SCM_BDIGITS(z)[ny] = num; return z;} - } - return scm_normbig(z); -} - - -SCM -scm_mulbig(x, nx, y, ny, sgn) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; -{ - scm_sizet i = 0, j = nx + ny; - unsigned long n = 0; - SCM z = scm_mkbig(j, sgn); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - while (j--) zds[j] = 0; - do { - j = 0; - if (x[i]) { - do { - n += zds[i + j] + ((unsigned long) x[i] * y[j]); - zds[i + j++] = SCM_BIGLO(n); - n = SCM_BIGDN(n); - } while (j < ny); - if (n) {zds[i + j] = n; n = 0;} - } - } while (++i < nx); - return scm_normbig(z); -} - - -unsigned int -scm_divbigdig(ds, h, div) - SCM_BIGDIG *ds; - scm_sizet h; - SCM_BIGDIG div; -{ - register unsigned long t2 = 0; - while(h--) { - t2 = SCM_BIGUP(t2) + ds[h]; - ds[h] = t2 / div; - t2 %= div; - } - return t2; -} - - - -SCM -scm_divbigint(x, z, sgn, mode) - SCM x; - long z; - int sgn; - int mode; -{ - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - register unsigned long t2 = 0; - register SCM_BIGDIG *ds = SCM_BDIGITS(x); - scm_sizet nd = SCM_NUMDIGS(x); - while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z; - if (mode && t2) t2 = z - t2; - return SCM_MAKINUM(sgn ? -t2 : t2); - } - { -#ifndef SCM_DIGSTOOBIG - unsigned long t2 = scm_pseudolong(z); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&t2, - SCM_DIGSPERLONG, sgn, mode); -#else - SCM_BIGDIG t2[SCM_DIGSPERLONG]; - scm_longdigs(z, t2); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), t2, SCM_DIGSPERLONG, sgn, mode); -#endif - } -} - - -SCM -scm_divbigbig(x, nx, y, ny, sgn, modes) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; - int modes; -{ - /* modes description - 0 remainder - 1 scm_modulo - 2 quotient - 3 quotient but returns 0 if division is not exact. */ - scm_sizet i = 0, j = 0; - long num = 0; - unsigned long t2 = 0; - SCM z, newy; - SCM_BIGDIG d = 0, qhat, *zds, *yds; - /* algorithm requires nx >= ny */ - if (nx < ny) - switch (modes) { - case 0: /* remainder -- just return x */ - z = scm_mkbig(nx, sgn); zds = SCM_BDIGITS(z); - do {zds[i] = x[i];} while (++i < nx); - return z; - case 1: /* scm_modulo -- return y-x */ - z = scm_mkbig(ny, sgn); zds = SCM_BDIGITS(z); - do { - num += (long) y[i] - x[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = num; num = 0;} - } while (++i < nx); - while (i < ny) { - num += y[i]; - if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;} - else {zds[i++] = num; num = 0;} - } - goto doadj; - case 2: return SCM_INUM0; /* quotient is zero */ - case 3: return 0; /* the division is not exact */ - } - - z = scm_mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = SCM_BDIGITS(z); - if (nx==ny) zds[nx+1] = 0; - while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */ - if (y[ny-1] < (SCM_BIGRAD>>1)) { /* normalize operands */ - d = SCM_BIGRAD/(y[ny-1]+1); - newy = scm_mkbig(ny, 0); yds = SCM_BDIGITS(newy); - while(j < ny) - {t2 += (unsigned long) y[j]*d; yds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);} - y = yds; j = 0; t2 = 0; - while(j < nx) - {t2 += (unsigned long) x[j]*d; zds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);} - zds[j] = t2; - } - else {zds[j = nx] = 0; while (j--) zds[j] = x[j];} - j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */ - do { /* loop over digits of quotient */ - if (zds[j]==y[ny-1]) qhat = SCM_BIGRAD-1; - else qhat = (SCM_BIGUP(zds[j]) + zds[j-1])/y[ny-1]; - if (!qhat) continue; - i = 0; num = 0; t2 = 0; - do { /* multiply and subtract */ - t2 += (unsigned long) y[i] * qhat; - num += zds[j - ny + i] - SCM_BIGLO(t2); - if (num < 0) {zds[j - ny + i] = num + SCM_BIGRAD; num = -1;} - else {zds[j - ny + i] = num; num = 0;} - t2 = SCM_BIGDN(t2); - } while (++i < ny); - num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */ - while (num) { /* "add back" required */ - i = 0; num = 0; qhat--; - do { - num += (long) zds[j - ny + i] + y[i]; - zds[j - ny + i] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (++i < ny); - num--; - } - if (modes & 2) zds[j] = qhat; - } while (--j >= ny); - switch (modes) { - case 3: /* check that remainder==0 */ - for(j = ny;j && !zds[j-1];--j) ; if (j) return 0; - case 2: /* move quotient down in z */ - j = (nx==ny ? nx+2 : nx+1) - ny; - for (i = 0;i < j;i++) zds[i] = zds[i+ny]; - ny = i; - break; - case 1: /* subtract for scm_modulo */ - i = 0; num = 0; j = 0; - do {num += y[i] - zds[i]; - j = j | zds[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = num; num = 0;} - } while (++i < ny); - if (!j) return SCM_INUM0; - case 0: /* just normalize remainder */ - if (d) scm_divbigdig(zds, ny, d); - } - doadj: - for(j = ny;j && !zds[j-1];--j) ; - if (j * SCM_BITSPERDIG <= sizeof(SCM)*SCM_CHAR_BIT) - if SCM_INUMP(z = scm_big2inum(z, j)) return z; - return scm_adjbig(z, j); -} -#endif - - - - - -/*** NUMBERS -> STRINGS ***/ -#ifdef SCM_FLOATS -int scm_dblprec; -static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, - 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, - 5e-11,5e-12,5e-13,5e-14,5e-15, - 5e-16,5e-17,5e-18,5e-19,5e-20}; - - - - -static scm_sizet idbl2str SCM_P ((double f, char *a)); - -static scm_sizet -idbl2str(f, a) - double f; - char *a; -{ - int efmt, dpt, d, i, wp = scm_dblprec; - scm_sizet ch = 0; - int exp = 0; - - if (f == 0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ - if (f < 0.0) {f = -f;a[ch++]='-';} - else if (f > 0.0) ; - else goto funny; - if (IS_INF(f)) - { - if (ch == 0) a[ch++]='+'; - funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch; - } -# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;} - while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;} -# else - while (f < 1.0) {f *= 10.0; exp--;} - while (f > 10.0) {f /= 10.0; exp++;} -# endif - if (f+fx[wp] >= 10.0) {f = 1.0; exp++;} - zero: -# ifdef ENGNOT - dpt = (exp+9999)%3; - exp -= dpt++; - efmt = 1; -# else - efmt = (exp < -3) || (exp > wp+2); - if (!efmt) - if (exp < 0) { - a[ch++] = '0'; - a[ch++] = '.'; - dpt = exp; - while (++dpt) a[ch++] = '0'; - } else - dpt = exp+1; - else - dpt = 1; -# endif - - do { - d = f; - f -= d; - a[ch++] = d+'0'; - if (f < fx[wp]) break; - if (f+fx[wp] >= 1.0) { - a[ch-1]++; - break; - } - f *= 10.0; - if (!(--dpt)) a[ch++] = '.'; - } while (wp--); - - if (dpt > 0) -# ifndef ENGNOT - if ((dpt > 4) && (exp > 6)) { - d = (a[0]=='-'?2:1); - for (i = ch++; i > d; i--) - a[i] = a[i-1]; - a[d] = '.'; - efmt = 1; - } else -# endif - { - while (--dpt) a[ch++] = '0'; - a[ch++] = '.'; - } - if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */ - if (efmt && exp) { - a[ch++] = 'e'; - if (exp < 0) { - exp = -exp; - a[ch++] = '-'; - } - for (i = 10; i <= exp; i *= 10); - for (i /= 10; i; i /= 10) { - a[ch++] = exp/i + '0'; - exp %= i; - } - } - return ch; -} - - -static scm_sizet iflo2str SCM_P ((SCM flt, char *str)); - -static scm_sizet -iflo2str(flt, str) - SCM flt; - char *str; -{ - scm_sizet i; -# ifdef SCM_SINGLES - if SCM_SINGP(flt) i = idbl2str(SCM_FLO(flt), str); - else -# endif - i = idbl2str(SCM_REAL(flt), str); - if SCM_CPLXP(flt) { - if(0 <= SCM_IMAG(flt)) /* jeh */ - str[i++] = '+'; /* jeh */ - i += idbl2str(SCM_IMAG(flt), &str[i]); - str[i++] = 'i'; - } - return i; -} -#endif /* SCM_FLOATS */ - - -scm_sizet -scm_iint2str(num, rad, p) - long num; - int rad; - char *p; -{ - scm_sizet j; - register int i = 1, d; - register long n = num; - if (n < 0) {n = -n; i++;} - for (n /= rad;n > 0;n /= rad) i++; - j = i; - n = num; - if (n < 0) {n = -n; *p++ = '-'; i--;} - while (i--) { - d = n % rad; - n /= rad; - p[i] = d + ((d < 10) ? '0' : 'a' - 10); - } - return j; -} - - -#ifdef SCM_BIGDIG - -static SCM big2str SCM_P ((SCM b, register unsigned int radix)); - -static SCM -big2str(b, radix) - SCM b; - register unsigned int radix; -{ - SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */ - register SCM_BIGDIG *ds = SCM_BDIGITS(t); - scm_sizet i = SCM_NUMDIGS(t); - scm_sizet j = radix==16 ? (SCM_BITSPERDIG*i)/4+2 - : radix >= 10 ? (SCM_BITSPERDIG*i*241L)/800+2 - : (SCM_BITSPERDIG*i)+2; - scm_sizet k = 0; - scm_sizet radct = 0; - scm_sizet ch; /* jeh */ - SCM_BIGDIG radpow = 1, radmod = 0; - SCM ss = scm_makstr((long)j, 0); - char *s = SCM_CHARS(ss), c; - while ((long) radpow * radix < SCM_BIGRAD) { - radpow *= radix; - radct++; - } - s[0] = scm_tc16_bigneg==SCM_TYP16(b) ? '-' : '+'; - while ((i || radmod) && j) { - if (k == 0) { - radmod = (SCM_BIGDIG)scm_divbigdig(ds, i, radpow); - k = radct; - if (!ds[i-1]) i--; - } - c = radmod % radix; radmod /= radix; k--; - s[--j] = c < 10 ? c + '0' : c + 'a' - 10; - } - ch = s[0] == '-' ? 1 : 0; /* jeh */ - if (ch < j) { /* jeh */ - for(i = j;j < SCM_LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ - scm_vector_set_length_x(ss, (SCM)SCM_MAKINUM(ch+SCM_LENGTH(ss)-i)); /* jeh */ - } - return ss; -} -#endif - - -SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string); - -SCM -scm_number_to_string(x, radix) - SCM x; - SCM radix; -{ - if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L); - else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string); -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - char num_buf[SCM_FLOBUFLEN]; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return big2str(x, (unsigned int)SCM_INUM(radix)); -# ifndef RECKLESS - if (!(SCM_INEXP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_number_to_string); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_number_to_string); -# endif - return scm_makfromstr(num_buf, iflo2str(x, num_buf), 0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_number_to_string); - return big2str(x, (unsigned int)SCM_INUM(radix)); - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_number_to_string); -# endif -#endif - { - char num_buf[SCM_INTBUFLEN]; - return scm_makfromstr(num_buf, - scm_iint2str(SCM_INUM(x), (int)SCM_INUM(radix), num_buf), 0); - } -} - - -/* These print routines are stubbed here so that scm_repl.c doesn't need - SCM_FLOATS or SCM_BIGDIGs conditionals */ - -int -scm_floprint(sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ -#ifdef SCM_FLOATS - char num_buf[SCM_FLOBUFLEN]; - scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port); -#else - scm_ipruk("float", sexp, port); -#endif - return !0; -} - - - -int -scm_bigprint(exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ -#ifdef SCM_BIGDIG - exp = big2str(exp, (unsigned int)10); - scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port); -#else - scm_ipruk("bignum", exp, port); -#endif - return !0; -} -/*** END nums->strs ***/ - -/*** STRINGS -> NUMBERS ***/ - -static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix)); - -static SCM -scm_small_istr2int(str, len, radix) - char *str; - long len; - long radix; -{ - register long n = 0, ln; - register int c; - register int i = 0; - int lead_neg = 0; - if (0 >= len) return SCM_BOOL_F; /* zero scm_length */ - switch (*str) { /* leading sign */ - case '-': lead_neg = 1; - case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - - do { - switch (c = str[i++]) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accumulate; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accumulate: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - ln = n; - n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl; - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } while (i < len); - if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl; - return SCM_MAKINUM(n); - ovfl: /* overflow scheme integer */ - return SCM_BOOL_F; -} - - - -SCM -scm_istr2int(str, len, radix) - char *str; - long len; - long radix; -{ - scm_sizet j; - register scm_sizet k, blen = 1; - scm_sizet i = 0; - int c; - SCM res; - register SCM_BIGDIG *ds; - register unsigned long t2; - - if (0 >= len) return SCM_BOOL_F; /* zero scm_length */ - - /* Short numbers we parse directly into an int, to avoid the overhead - of creating a bignum. */ - if (len < 6) - return scm_small_istr2int (str, len, radix); - - if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG); - else if (10 <= radix) - j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25); - else j = 1+(len*sizeof(char))/(SCM_BITSPERDIG); - switch (str[0]) { /* leading sign */ - case '-': - case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - res = scm_mkbig(j, '-'==str[0]); - ds = SCM_BDIGITS(res); - for (k = j;k--;) ds[k] = 0; - do { - switch (c = str[i++]) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accumulate; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accumulate: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - k = 0; - t2 = c; - moretodo: - while(k < blen) { - /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ - t2 += ds[k]*radix; - ds[k++] = SCM_BIGLO(t2); - t2 = SCM_BIGDN(t2); - } - if (blen > j) - scm_num_overflow ("bignum"); - if (t2) {blen++; goto moretodo;} - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } while (i < len); - if (blen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM)) - if SCM_INUMP(res = scm_big2inum(res, blen)) return res; - if (j==blen) return res; - return scm_adjbig(res, blen); -} - -#ifdef SCM_FLOATS - -SCM -scm_istr2flo(str, len, radix) - char *str; - long len; - long radix; -{ - register int c, i = 0; - double lead_sgn; - double res = 0.0, tmp = 0.0; - int flg = 0; - int point = 0; - SCM second; - - if (i >= len) return SCM_BOOL_F; /* zero scm_length */ - - switch (*str) { /* leading sign */ - case '-': lead_sgn = -1.0; i++; break; - case '+': lead_sgn = 1.0; i++; break; - default : lead_sgn = 0.0; - } - if (i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - - if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */ - if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl(0.0, lead_sgn); - } - do { /* check initial digits */ - switch (c = str[i]) { - case DIGITS: - c = c - '0'; - goto accum1; - case 'D': case 'E': case 'F': - if (radix==10) goto out1; /* must be exponent */ - case 'A': case 'B': case 'C': - c = c-'A'+10; - goto accum1; - case 'd': case 'e': case 'f': - if (radix==10) goto out1; - case 'a': case 'b': case 'c': - c = c-'a'+10; - accum1: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - res = res * radix + c; - flg = 1; /* res is valid */ - break; - default: - goto out1; - } - } while (++i < len); - out1: - - /* if true, then we did see a digit above, and res is valid */ - if (i==len) goto done; - - /* By here, must have seen a digit, - or must have next char be a `.' with radix==10 */ - if (!flg) - if (!(str[i]=='.' && radix==10)) - return SCM_BOOL_F; - - while (str[i]=='#') { /* optional sharps */ - res *= radix; - if (++i==len) goto done; - } - - if (str[i]=='/') { - while (++i < len) { - switch (c = str[i]) { - case DIGITS: - c = c - '0'; - goto accum2; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accum2; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accum2: - if (c >= radix) return SCM_BOOL_F; - tmp = tmp * radix + c; - break; - default: - goto out2; - } - } - out2: - if (tmp==0.0) return SCM_BOOL_F; /* `slash zero' not allowed */ - if (i < len) - while (str[i]=='#') { /* optional sharps */ - tmp *= radix; - if (++i==len) break; - } - res /= tmp; - goto done; - } - - if (str[i]=='.') { /* decimal point notation */ - if (radix != 10) return SCM_BOOL_F; /* must be radix 10 */ - while (++i < len) { - switch (c = str[i]) { - case DIGITS: - point--; - res = res*10.0 + c-'0'; - flg = 1; - break; - default: - goto out3; - } - } - out3: - if (!flg) return SCM_BOOL_F; /* no digits before or after decimal point */ - if (i==len) goto adjust; - while (str[i]=='#') { /* ignore remaining sharps */ - if (++i==len) goto adjust; - } - } - - switch (str[i]) { /* exponent */ - case 'd': case 'D': - case 'e': case 'E': - case 'f': case 'F': - case 'l': case 'L': - case 's': case 'S': { - int expsgn = 1, expon = 0; - if (radix != 10) return SCM_BOOL_F; /* only in radix 10 */ - if (++i==len) return SCM_BOOL_F; /* bad exponent */ - switch (str[i]) { - case '-': expsgn=(-1); - case '+': if (++i==len) return SCM_BOOL_F; /* bad exponent */ - } - if (str[i] < '0' || str[i] > '9') return SCM_BOOL_F; /* bad exponent */ - do { - switch (c = str[i]) { - case DIGITS: - expon = expon*10 + c-'0'; - if (expon > MAXEXP) return SCM_BOOL_F; /* exponent too large */ - break; - default: - goto out4; - } - } while (++i < len); - out4: - point += expsgn*expon; - } - } - - adjust: - if (point >= 0) - while (point--) res *= 10.0; - else -# ifdef _UNICOS - while (point++) res *= 0.1; -# else - while (point++) res /= 10.0; -# endif - - done: - /* at this point, we have a legitimate floating point result */ - if (lead_sgn==-1.0) res = -res; - if (i==len) return scm_makdbl(res, 0.0); - - if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */ - if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl(0.0, res); - } - - switch (str[i++]) { - case '-': lead_sgn = -1.0; break; - case '+': lead_sgn = 1.0; break; - case '@': { /* polar input for complex number */ - /* get a `real' for scm_angle */ - second = scm_istr2flo(&str[i], (long)(len-i), radix); - if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `real' */ - if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `real' */ - tmp = SCM_REALPART(second); - return scm_makdbl(res*cos(tmp), res*sin(tmp)); - } - default: return SCM_BOOL_F; - } - - /* at this point, last char must be `i' */ - if (str[len-1] != 'i' && str[len-1] != 'I') return SCM_BOOL_F; - /* handles `x+i' and `x-i' */ - if (i==(len-1)) return scm_makdbl(res, lead_sgn); - /* get a `ureal' for complex part */ - second = scm_istr2flo(&str[i], (long)((len-i)-1), radix); - if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `ureal' */ - if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `ureal' */ - tmp = SCM_REALPART(second); - if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */ - return scm_makdbl(res, (lead_sgn*tmp)); -} -#endif /* SCM_FLOATS */ - - - -SCM -scm_istring2number(str, len, radix) - char *str; - long len; - long radix; -{ - int i = 0; - char ex = 0; - char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ - SCM res; - if (len==1) - if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */ - return SCM_BOOL_F; - - while ((len-i) >= 2 && str[i]=='#' && ++i) - switch (str[i++]) { - case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break; - case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break; - case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break; - case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break; - case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break; - case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break; - default: return SCM_BOOL_F; - } - - switch (ex) { - case 1: - return scm_istr2int(&str[i], len-i, radix); - case 0: - res = scm_istr2int(&str[i], len-i, radix); - if SCM_NFALSEP(res) return res; -#ifdef SCM_FLOATS - case 2: return scm_istr2flo(&str[i], len-i, radix); -#endif - } - return SCM_BOOL_F; -} - - -SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number); - -SCM -scm_string_to_number(str, radix) - SCM str; - SCM radix; -{ - SCM answer; - if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L); - else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_string_to_number); - SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, s_string_to_number); - answer = scm_istring2number(SCM_ROCHARS(str), SCM_ROLENGTH(str), SCM_INUM(radix)); - return scm_return_first (answer, str); -} -/*** END strs->nums ***/ - -#ifdef SCM_FLOATS - -SCM -scm_makdbl (x, y) - double x; - double y; -{ - SCM z; - if ((y==0.0) && (x==0.0)) return scm_flo0; - SCM_NEWCELL(z); - SCM_DEFER_INTS; - if (y==0.0) { -# ifdef SCM_SINGLES - float fx = x; -# ifndef SCM_SINGLESONLY - if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x)) -# endif - { - SCM_SETCAR (z, scm_tc_flo); - SCM_FLO(z) = x; - SCM_ALLOW_INTS; - return z; - } -# endif/* def SCM_SINGLES */ - SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real")); - SCM_SETCAR (z, scm_tc_dblr); - } - else { - SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex")); - SCM_SETCAR (z, scm_tc_dblc); - SCM_IMAG(z) = y; - } - SCM_REAL(z) = x; - SCM_ALLOW_INTS; - return z; -} -#endif - - - -SCM -scm_bigequal(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_BIGDIG - if (0==scm_bigcomp(x, y)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - -SCM -scm_floequal(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if (!(SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y)))) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - - -SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p); - -SCM -scm_number_p(x) - SCM x; -{ - if SCM_INUMP(x) return SCM_BOOL_T; -#ifdef SCM_FLOATS - if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T; -#else -# ifdef SCM_BIGDIG - if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T; -# endif -#endif - return SCM_BOOL_F; -} - - - -#ifdef SCM_FLOATS -SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p); - -SCM -scm_real_p(x) - SCM x; -{ - if (SCM_INUMP(x)) - return SCM_BOOL_T; - if (SCM_IMP(x)) - return SCM_BOOL_F; - if (SCM_REALP(x)) - return SCM_BOOL_T; -# ifdef SCM_BIGDIG - if (SCM_BIGP(x)) - return SCM_BOOL_T; -# endif - return SCM_BOOL_F; -} - - - -SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p); - -SCM -scm_integer_p(x) - SCM x; -{ - double r; - if SCM_INUMP(x) return SCM_BOOL_T; - if SCM_IMP(x) return SCM_BOOL_F; -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return SCM_BOOL_T; -# endif - if (!SCM_INEXP(x)) return SCM_BOOL_F; - if (SCM_CPLXP(x)) return SCM_BOOL_F; - r = SCM_REALPART(x); - if (r==floor(r)) return SCM_BOOL_T; - return SCM_BOOL_F; -} - - - -#endif /* SCM_FLOATS */ - -SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p); - -SCM -scm_inexact_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - - -SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p); - -SCM -scm_num_eq_p (x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - SCM t; - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_eq_p); -# endif - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: - return (SCM_REALP(y) && (scm_big2dbl(x)==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F; - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_eq_p); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto realint;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if SCM_CPLXP(x) - return (SCM_CPLXP(y) && (SCM_IMAG(x)==SCM_IMAG(y))) ? SCM_BOOL_T : SCM_BOOL_F; - return SCM_CPLXP(y) ? SCM_BOOL_F : SCM_BOOL_T; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif -# endif - realint: - return (SCM_REALP(y) && (((double)SCM_INUM(x))==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_eq_p); - if SCM_INUMP(y) return SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif - return SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_eq_p); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_eq_p); -# endif -#endif - return ((long)x==(long)y) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p); - -SCM -scm_less_p(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_less_p); -# endif - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_REALP(y), bady); - return (scm_big2dbl(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_less_p); -# endif - if (SCM_INUMP(y)) - return (SCM_REALPART(x) < ((double)SCM_INUM(y))) ? SCM_BOOL_T : SCM_BOOL_F; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (SCM_REALPART(x) < scm_big2dbl(y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif -# endif - return (((double)SCM_INUM(x)) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_less_p); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif - return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_less_p); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_less_p); -# endif -#endif - return ((long)x < (long)y) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p); - -SCM -scm_gr_p(x, y) - SCM x; - SCM y; -{ - return scm_less_p(y, x); -} - - - -SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p); - -SCM -scm_leq_p(x, y) - SCM x; - SCM y; -{ - return SCM_BOOL_NOT(scm_less_p(y, x)); -} - - - -SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p); - -SCM -scm_geq_p(x, y) - SCM x; - SCM y; -{ - return SCM_BOOL_NOT(scm_less_p(x, y)); -} - - - -SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p); - -SCM -scm_zero_p(z) - SCM z; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(z) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_zero_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_zero_p); -# endif - return (z==scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(z) { - SCM_ASSERT(SCM_NIMP(z) && SCM_BIGP(z), z, SCM_ARG1, s_zero_p); - return SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(z), z, SCM_ARG1, s_zero_p); -# endif -#endif - return (z==SCM_INUM0) ? SCM_BOOL_T: SCM_BOOL_F; -} - - - -SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p); - -SCM -scm_positive_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_REALP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_positive_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_positive_p); -# endif - return (SCM_REALPART(x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_positive_p); - return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_positive_p); -# endif -#endif - return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p); - -SCM -scm_negative_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T; -# ifndef RECKLESS - if (!(SCM_REALP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_negative_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_negative_p); -# endif - return (SCM_REALPART(x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_negative_p); - return (SCM_TYP16(x)==scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_negative_p); -# endif -#endif - return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max); - -SCM -scm_max(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double z; -#endif - if SCM_UNBNDP(y) { -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_max); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? y : x; - SCM_ASRTGO(SCM_REALP(y), bady); - z = scm_big2dbl(x); - return (z < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_max); -# endif - if (SCM_INUMP(y)) - return (SCM_REALPART(x) < (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if (SCM_BIGP(y)) - return (SCM_REALPART(x) < (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) < SCM_REALPART(y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? x : y; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif -# endif - return ((z = SCM_INUM(x)) < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_max); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (1==scm_bigcomp(x, y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif - return SCM_BIGSIGN(y) ? x : y; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_max); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_max); -# endif -#endif - return ((long)x < (long)y) ? y : x; -} - - - - -SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min); - -SCM -scm_min(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double z; -#endif - if SCM_UNBNDP(y) { -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx:scm_wta(x, (char *)SCM_ARG1, s_min); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (-1==scm_bigcomp(x, y)) ? y : x; - SCM_ASRTGO(SCM_REALP(y), bady); - z = scm_big2dbl(x); - return (z > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_min); -# endif - if SCM_INUMP(y) return (SCM_REALPART(x) > (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (SCM_REALPART(x) > (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) > SCM_REALPART(y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? y : x; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif -# endif - return ((z = SCM_INUM(x)) > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_min); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (-1==scm_bigcomp(x, y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif - return SCM_BIGSIGN(y) ? y : x; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_min); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_min); -# endif -#endif - return ((long)x > (long)y) ? y : x; -} - - - - -SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum); - -SCM -scm_sum(x, y) - SCM x; - SCM y; -{ - if SCM_UNBNDP(y) { - if SCM_UNBNDP(x) return SCM_INUM0; -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_sum); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - SCM t; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;} - return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0); - } - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: return scm_makdbl(scm_big2dbl(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0); - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} -# ifndef RECKLESS - else if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif -# endif - { double i = 0.0; - if SCM_CPLXP(x) i = SCM_IMAG(x); - if SCM_CPLXP(y) i += SCM_IMAG(y); - return scm_makdbl(SCM_REALPART(x)+SCM_REALPART(y), i); } - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) - intbig: { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# endif - } - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - intreal: return scm_makdbl(SCM_INUM(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM t; - SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx); - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;} - return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif - intbig: { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# endif - } - } -# else - SCM_ASRTGO(SCM_INUMP(x), badx); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_sum); -# endif -#endif - x = SCM_INUM(x)+SCM_INUM(y); - if SCM_FIXABLE(x) return SCM_MAKINUM(x); -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double)x, 0.0); -# else - scm_num_overflow (s_sum); - return SCM_UNSPECIFIED; -# endif -#endif -} - - - - -SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference); - -SCM -scm_difference(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_difference); -# endif - if SCM_UNBNDP(y) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) { - x = scm_copybig(x, !SCM_BIGSIGN(x)); - return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ? - scm_big2inum(x, SCM_NUMDIGS(x)) : x; - } -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - return scm_makdbl(-SCM_REALPART(x), SCM_CPLXP(x)?-SCM_IMAG(x):0.0); - } - if SCM_INUMP(y) return scm_sum(x, SCM_MAKINUM(-SCM_INUM(y))); -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(x) { - if SCM_BIGP(y) return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ? - scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) : - scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0); - SCM_ASRTGO(SCM_INEXP(y), bady); - return scm_makdbl(scm_big2dbl(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_BIGP(y) return scm_makdbl(SCM_REALPART(x)-scm_big2dbl(y), SCM_CPLXP(x)?SCM_IMAG(x):0.0); - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_INEXP(x), badx); - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if SCM_CPLXP(x) - if SCM_CPLXP(y) - return scm_makdbl(SCM_REAL(x)-SCM_REAL(y), SCM_IMAG(x)-SCM_IMAG(y)); - else - return scm_makdbl(SCM_REAL(x)-SCM_REALPART(y), SCM_IMAG(x)); - return scm_makdbl(SCM_REALPART(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# endif - } -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif -# endif - return scm_makdbl(SCM_INUM(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_difference); - if SCM_UNBNDP(y) { - x = scm_copybig(x, !SCM_BIGSIGN(x)); - return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ? - scm_big2inum(x, SCM_NUMDIGS(x)) : x; - } - if SCM_INUMP(y) { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(y)); - return scm_addbig(&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); -# endif - } - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ? - scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) : - scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0); - } - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# endif - } - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_difference); - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_difference); -# endif -#endif - x = SCM_INUM(x)-SCM_INUM(y); - checkx: - if SCM_FIXABLE(x) return SCM_MAKINUM(x); -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double)x, 0.0); -# else - scm_num_overflow (s_difference); - return SCM_UNSPECIFIED; -# endif -#endif -} - - - - -SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product); - -SCM -scm_product(x, y) - SCM x; - SCM y; -{ - if SCM_UNBNDP(y) { - if SCM_UNBNDP(x) return SCM_MAKINUM(1L); -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_product); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - SCM t; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)); - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: { - double bg = scm_big2dbl(x); - return scm_makdbl(bg*SCM_REALPART(y), SCM_CPLXP(y)?bg*SCM_IMAG(y):0.0); } - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} -# ifndef RECKLESS - else if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif -# endif - if SCM_CPLXP(x) - if SCM_CPLXP(y) - return scm_makdbl(SCM_REAL(x)*SCM_REAL(y)-SCM_IMAG(x)*SCM_IMAG(y), - SCM_REAL(x)*SCM_IMAG(y)+SCM_IMAG(x)*SCM_REAL(y)); - else - return scm_makdbl(SCM_REAL(x)*SCM_REALPART(y), SCM_IMAG(x)*SCM_REALPART(y)); - return scm_makdbl(SCM_REALPART(x)*SCM_REALPART(y), - SCM_CPLXP(y)?SCM_REALPART(x)*SCM_IMAG(y):0.0); - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y; - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_mulbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# endif - } - } - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - intreal: return scm_makdbl(SCM_INUM(x)*SCM_REALPART(y), SCM_CPLXP(y)?SCM_INUM(x)*SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx); - if SCM_INUMP(y) {SCM t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif - intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y; - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_mulbig(&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# endif - } - } -# else - SCM_ASRTGO(SCM_INUMP(x), badx); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_product); -# endif -#endif - { - long i, j, k; - i = SCM_INUM(x); - if (0==i) return x; - j = SCM_INUM(y); - k = i * j; - y = SCM_MAKINUM(k); - if (k != SCM_INUM(y) || k/i != j) -#ifdef SCM_BIGDIG - { int sgn = (i < 0) ^ (j < 0); -# ifndef SCM_DIGSTOOBIG - i = scm_pseudolong(i); - j = scm_pseudolong(j); - return scm_mulbig((SCM_BIGDIG *)&i, SCM_DIGSPERLONG, - (SCM_BIGDIG *)&j, SCM_DIGSPERLONG, sgn); -# else /* SCM_DIGSTOOBIG */ - SCM_BIGDIG idigs[SCM_DIGSPERLONG]; - SCM_BIGDIG jdigs[SCM_DIGSPERLONG]; - scm_longdigs(i, idigs); - scm_longdigs(j, jdigs); - return scm_mulbig(idigs, SCM_DIGSPERLONG, jdigs, SCM_DIGSPERLONG, sgn); -# endif - } -#else -# ifdef SCM_FLOATS - return scm_makdbl(((double)i)*((double)j), 0.0); -# else - scm_num_overflow (s_product); -# endif -#endif - return y; - } -} - - - -double -scm_num2dbl (a, why) - SCM a; - char * why; -{ - if (SCM_INUMP (a)) - return (double) SCM_INUM (a); -#ifdef SCM_FLOATS - SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why); - if (SCM_REALP (a)) - return (SCM_REALPART (a)); -#endif -#ifdef SCM_BIGDIG - return scm_big2dbl (a); -#endif - SCM_ASSERT (0, a, "wrong type argument", why); - return SCM_UNSPECIFIED; -} - - -SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide); - -SCM -scm_divide(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double d, r, i, a; - if SCM_NINUMP(x) { -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_divide); -# endif - if SCM_UNBNDP(y) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return scm_makdbl(1.0/scm_big2dbl(x), 0.0); -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_REALP(x) return scm_makdbl(1.0/SCM_REALPART(x), 0.0); - r = SCM_REAL(x); i = SCM_IMAG(x); d = r*r+i*i; - return scm_makdbl(r/d, -i/d); - } -# ifdef SCM_BIGDIG - if SCM_BIGP(x) { - SCM z; - if SCM_INUMP(y) { - z = SCM_INUM(y); -#ifndef RECKLESS - if (!z) - scm_num_overflow (s_divide); -#endif - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - return scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z) ? - scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0) : scm_normbig(w); - } -# ifndef SCM_DIGSTOOBIG - z = scm_pseudolong(z); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&z, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3); -# else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);} -# endif - return z ? z : scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0); - } - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3); - return z ? z : scm_makdbl(scm_big2dbl(x)/scm_big2dbl(y), 0.0); - } - SCM_ASRTGO(SCM_INEXP(y), bady); - if SCM_REALP(y) return scm_makdbl(scm_big2dbl(x)/SCM_REALPART(y), 0.0); - a = scm_big2dbl(x); - goto complex_div; - } -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_INUMP(y) {d = SCM_INUM(y); goto basic_div;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {d = scm_big2dbl(y); goto basic_div;} - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if SCM_REALP(y) { - d = SCM_REALPART(y); - basic_div: return scm_makdbl(SCM_REALPART(x)/d, SCM_CPLXP(x)?SCM_IMAG(x)/d:0.0); - } - a = SCM_REALPART(x); - if SCM_REALP(x) goto complex_div; - r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i; - return scm_makdbl((a*r+SCM_IMAG(x)*i)/d, (SCM_IMAG(x)*r-a*i)/d); - } - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - return scm_makdbl(1.0/((double)SCM_INUM(x)), 0.0); - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return scm_makdbl(SCM_INUM(x)/scm_big2dbl(y), 0.0); -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif -# endif - if (SCM_REALP(y)) - return scm_makdbl(SCM_INUM(x)/SCM_REALPART(y), 0.0); - a = SCM_INUM(x); - complex_div: - r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i; - return scm_makdbl((a*r)/d, (-a*i)/d); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM z; - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_divide); - if SCM_UNBNDP(y) goto ov; - if SCM_INUMP(y) { - z = SCM_INUM(y); - if (!z) goto ov; - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - if (scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z)) goto ov; - return w; - } -# ifndef SCM_DIGSTOOBIG - z = scm_pseudolong(z); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), &z, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3); -# else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);} -# endif - } else { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3); - } - if (!z) goto ov; - return z; - } - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - goto ov; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif - goto ov; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_divide); - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - goto ov; - } - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_divide); -# endif -#endif - { - long z = SCM_INUM(y); - if ((0==z) || SCM_INUM(x)%z) goto ov; - z = SCM_INUM(x)/z; - if SCM_FIXABLE(z) return SCM_MAKINUM(z); -#ifdef SCM_BIGDIG - return scm_long2big(z); -#endif -#ifdef SCM_FLOATS - ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0); -#else - ov: scm_num_overflow (s_divide); - return SCM_UNSPECIFIED; -#endif - } -} - - - - -#ifdef SCM_FLOATS -SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh); - -double -scm_asinh(x) - double x; -{ - return log(x+sqrt(x*x+1)); -} - - - - -SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh); - -double -scm_acosh(x) - double x; -{ - return log(x+sqrt(x*x-1)); -} - - - - -SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh); - -double -scm_atanh(x) - double x; -{ - return 0.5*log((1+x)/(1-x)); -} - - - - -SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate); - -double -scm_truncate(x) - double x; -{ - if (x < 0.0) return -floor(-x); - return floor(x); -} - - - -SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round); - -double -scm_round(x) - double x; -{ - double plus_half = x + 0.5; - double result = floor(plus_half); - /* Adjust so that the scm_round is towards even. */ - return (plus_half == result && plus_half / 2 != floor(plus_half / 2)) - ? result - 1 : result; -} - - - -SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact); - -double -scm_exact_to_inexact(z) - double z; -{ - return z; -} - - -SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor); -SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil); -SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)())sqrt); -SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)())fabs); -SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)())exp); -SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)())log); -SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)())sin); -SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)())cos); -SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)())tan); -SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)())asin); -SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)())acos); -SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)())atan); -SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)())sinh); -SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)())cosh); -SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh); - -struct dpair {double x, y;}; - -static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy)); - -static void -scm_two_doubles(z1, z2, sstring, xy) - SCM z1, z2; - char *sstring; - struct dpair *xy; -{ - if SCM_INUMP(z1) xy->x = SCM_INUM(z1); - else { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z1), badz1); - if SCM_BIGP(z1) xy->x = scm_big2dbl(z1); - else { -# ifndef RECKLESS - if (!(SCM_REALP(z1))) - badz1: scm_wta(z1, (char *)SCM_ARG1, sstring); -# endif - xy->x = SCM_REALPART(z1);} -# else - {SCM_ASSERT(SCM_NIMP(z1) && SCM_REALP(z1), z1, SCM_ARG1, sstring); - xy->x = SCM_REALPART(z1);} -# endif - } - if SCM_INUMP(z2) xy->y = SCM_INUM(z2); - else { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z2), badz2); - if SCM_BIGP(z2) xy->y = scm_big2dbl(z2); - else { -# ifndef RECKLESS - if (!(SCM_REALP(z2))) - badz2: scm_wta(z2, (char *)SCM_ARG2, sstring); -# endif - xy->y = SCM_REALPART(z2);} -# else - {SCM_ASSERT(SCM_NIMP(z2) && SCM_REALP(z2), z2, SCM_ARG2, sstring); - xy->y = SCM_REALPART(z2);} -# endif - } -} - - - - -SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt); - -SCM -scm_sys_expt(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_sys_expt, &xy); - return scm_makdbl(pow(xy.x, xy.y), 0.0); -} - - - -SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2); - -SCM -scm_sys_atan2(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_sys_atan2, &xy); - return scm_makdbl(atan2(xy.x, xy.y), 0.0); -} - - - -SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular); - -SCM -scm_make_rectangular(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_make_rectangular, &xy); - return scm_makdbl(xy.x, xy.y); -} - - - -SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar); - -SCM -scm_make_polar(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_make_polar, &xy); - return scm_makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y)); -} - - - - -SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part); - -SCM -scm_real_part(z) - SCM z; -{ - if SCM_NINUMP(z) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return z; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_real_part); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_real_part); -# endif - if SCM_CPLXP(z) return scm_makdbl(SCM_REAL(z), 0.0); - } - return z; -} - - - -SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part); - -SCM -scm_imag_part(z) - SCM z; -{ - if SCM_INUMP(z) return SCM_INUM0; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return SCM_INUM0; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_imag_part); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_imag_part); -# endif - if SCM_CPLXP(z) return scm_makdbl(SCM_IMAG(z), 0.0); - return scm_flo0; -} - - - -SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude); - -SCM -scm_magnitude(z) - SCM z; -{ - if SCM_INUMP(z) return scm_abs(z); -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return scm_abs(z); -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_magnitude); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_magnitude); -# endif - if SCM_CPLXP(z) - { - double i = SCM_IMAG(z), r = SCM_REAL(z); - return scm_makdbl(sqrt(i*i+r*r), 0.0); - } - return scm_makdbl(fabs(SCM_REALPART(z)), 0.0); -} - - - - -SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle); - -SCM -scm_angle(z) - SCM z; -{ - double x, y = 0.0; - if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) {x = (SCM_TYP16(z)==scm_tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} -# ifndef RECKLESS - if (!(SCM_INEXP(z))) { - badz: scm_wta(z, (char *)SCM_ARG1, s_angle);} -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_angle); -# endif - if (SCM_REALP(z)) - { - x = SCM_REALPART(z); - goto do_angle; - } - x = SCM_REAL(z); y = SCM_IMAG(z); - do_angle: - return scm_makdbl(atan2(y, x), 0.0); -} - - -SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact); - -SCM -scm_inexact_to_exact(z) - SCM z; -{ - if SCM_INUMP(z) return z; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return z; -# ifndef RECKLESS - if (!(SCM_REALP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_inexact_to_exact); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_REALP(z), z, SCM_ARG1, s_inexact_to_exact); -# endif -# ifdef SCM_BIGDIG - { - double u = floor(SCM_REALPART(z)+0.5); - if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM)) { - /* Negation is a workaround for HP700 cc bug */ - SCM ans = SCM_MAKINUM((long)u); - if (SCM_INUM(ans)==(long)u) return ans; - } - SCM_ASRTGO(!IS_INF(u), badz); /* problem? */ - return scm_dbl2big(u); - } -# else - return SCM_MAKINUM((long)floor(SCM_REALPART(z)+0.5)); -# endif -} - - - -#else /* ~SCM_FLOATS */ -SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc); - -SCM -scm_trunc(x) - SCM x; -{ - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate); - return x; -} - - - -#endif /* SCM_FLOATS */ - -#ifdef SCM_BIGDIG -# ifdef SCM_FLOATS -/* d must be integer */ - -SCM -scm_dbl2big(d) - double d; -{ - scm_sizet i = 0; - long c; - SCM_BIGDIG *digits; - SCM ans; - double u = (d < 0)?-d:d; - while (0 != floor(u)) {u /= SCM_BIGRAD;i++;} - ans = scm_mkbig(i, d < 0); - digits = SCM_BDIGITS(ans); - while (i--) { - u *= SCM_BIGRAD; - c = floor(u); - u -= c; - digits[i] = c; - } -#ifndef RECKLESS - if (u != 0) - scm_num_overflow ("dbl2big"); -#endif - return ans; -} - - - - -double -scm_big2dbl(b) - SCM b; -{ - double ans = 0.0; - scm_sizet i = SCM_NUMDIGS(b); - SCM_BIGDIG *digits = SCM_BDIGITS(b); - while (i--) ans = digits[i] + SCM_BIGRAD*ans; - if (scm_tc16_bigneg==SCM_TYP16(b)) return -ans; - return ans; -} -# endif -#endif - - -SCM -scm_long2num(sl) - long sl; -{ - if (!SCM_FIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_long2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} - - -#ifdef LONGLONGS - -SCM -scm_long_long2num(sl) - long_long sl; -{ - if (!SCM_FIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_long_long2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} -#endif - - - -SCM -scm_ulong2num(sl) - unsigned long sl; -{ - if (!SCM_POSFIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_ulong2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} - - -long -scm_num2long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long res; - if (SCM_INUMP(num)) - { - res = SCM_INUM(num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if (SCM_REALP(num)) - { - double u = SCM_REALPART(num); - res = u; - if ((double)res == u) - { - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if (SCM_BIGP(num)) { - long oldres; - scm_sizet l; - res = 0; - oldres = 0; - for(l = SCM_NUMDIGS(num);l--;) - { - res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - if (res < oldres) - goto errout; - oldres = res; - } - if (SCM_TYP16 (num) == scm_tc16_bigpos) - return res; - else - return -res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - - - - -long -num2long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long res; - if SCM_INUMP(num) { - res = SCM_INUM((long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if SCM_REALP(num) { - double u = SCM_REALPART(num); - if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u) - && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if SCM_BIGP(num) { - scm_sizet l = SCM_NUMDIGS(num); - SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout); - res = 0; - for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - -#ifdef LONGLONGS - -long_long -scm_num2long_long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long_long res; - if SCM_INUMP(num) { - res = SCM_INUM((long_long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if SCM_REALP(num) { - double u = SCM_REALPART(num); - if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u) - && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if SCM_BIGP(num) { - scm_sizet l = SCM_NUMDIGS(num); - SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout); - res = 0; - for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l]; - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} -#endif - - - -unsigned long -scm_num2ulong(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - unsigned long res; - if (SCM_INUMP(num)) - { - res = SCM_INUM((unsigned long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if (SCM_REALP(num)) - { - double u = SCM_REALPART(num); - if ((0 <= u) && (u <= (unsigned long)~0L)) - { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if (SCM_BIGP(num)) { - unsigned long oldres; - scm_sizet l; - res = 0; - oldres = 0; - for(l = SCM_NUMDIGS(num);l--;) - { - res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - if (res < oldres) - goto errout; - oldres = res; - } - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - -#ifdef SCM_FLOATS -# ifndef DBL_DIG -static void add1 SCM_P ((double f, double *fsum)); -static void add1(f, fsum) - double f, *fsum; -{ - *fsum = f + 1.0; -} -# endif -#endif - - - -void -scm_init_numbers () -{ -#ifdef SCM_FLOATS - SCM_NEWCELL(scm_flo0); -# ifdef SCM_SINGLES - SCM_SETCAR (scm_flo0, scm_tc_flo); - SCM_FLO(scm_flo0) = 0.0; -# else - SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real")); - SCM_REAL(scm_flo0) = 0.0; - SCM_SETCAR (scm_flo0, scm_tc_dblr); -# endif -# ifdef DBL_DIG - scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; -# else - { /* determine floating point precision */ - double f = 0.1; - double fsum = 1.0+f; - while (fsum != 1.0) { - f /= 10.0; - if (++scm_dblprec > 20) break; - add1(f, &fsum); - } - scm_dblprec = scm_dblprec-1; - } -# endif /* DBL_DIG */ -#endif -#include "numbers.x" -} - diff --git a/libguile/numbers.h b/libguile/numbers.h deleted file mode 100644 index d34e09d9c..000000000 --- a/libguile/numbers.h +++ /dev/null @@ -1,323 +0,0 @@ -/* classes: h_files */ - -#ifndef NUMBERSH -#define NUMBERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -/* Immediate Numbers - * - * Inums are exact integer data that fits within an SCM word. - * - * SCM_INUMP applies only to values known to be Scheme objects. - * In particular, SCM_INUMP (SCM_CAR (x)) is valid only if x is known - * to be a SCM_CONSP. If x is only known to be a SCM_NIMP, - * SCM_INUMP (SCM_CAR (x)) can give wrong answers. - */ - -#define SCM_INUMP(x) (2 & (int)(x)) -#define SCM_NINUMP(x) (!SCM_INUMP(x)) - -#ifdef __TURBOC__ -/* shifts of more than one are done by a library call, single shifts are - * performed in registers - */ -# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L) -#else -# define SCM_MAKINUM(x) (((x)<<2)+2L) -#endif /* def __TURBOC__ */ - - -/* SCM_SRS is signed right shift */ -/* Turbo C++ v1.0 has a bug with right shifts of signed longs! - * It is believed to be fixed in Turbo C++ v1.01 - */ -#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) -# define SCM_SRS(x, y) ((x)>>y) -# ifdef __TURBOC__ -# define SCM_INUM(x) (((x)>>1)>>1) -# else -# define SCM_INUM(x) SCM_SRS(x, 2) -# endif /* def __TURBOC__ */ -#else -# define SCM_SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y) -# define SCM_INUM(x) SCM_SRS(x, 2) -#endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */ - - -/* A name for 0. - */ -#define SCM_INUM0 ((SCM) 2) - - - -/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM. - */ -#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) -#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n)) - -/* SCM_INTBUFLEN is the maximum number of characters neccessary for the - * printed or scm_string representation of an exact immediate. - */ - -#ifndef SCM_CHAR_BIT -# define SCM_CHAR_BIT 8 -#endif /* ndef SCM_CHAR_BIT */ -#ifndef SCM_LONG_BIT -# define SCM_LONG_BIT (SCM_CHAR_BIT*sizeof(long)/sizeof(char)) -#endif /* ndef SCM_LONG_BIT */ -#define SCM_INTBUFLEN (5+SCM_LONG_BIT) - -/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the - * printed or scm_string representation of an inexact number. - */ - -#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) - - - - -/* Numbers - */ - -#define SCM_INEXP(x) (SCM_TYP16(x)==scm_tc16_flo) -#define SCM_CPLXP(x) (SCM_CAR(x)==scm_tc_dblc) -#define SCM_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real)) -#define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double)))) -/* ((&SCM_REAL(x))[1]) */ - - -#ifdef SCM_SINGLES -#define SCM_REALP(x) ((~SCM_REAL_PART & SCM_CAR(x))==scm_tc_flo) -#define SCM_SINGP(x) (SCM_CAR(x)==scm_tc_flo) -#define SCM_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num) -#define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x)) -#else /* SCM_SINGLES */ -#define SCM_REALP(x) (SCM_CAR(x)==scm_tc_dblr) -#define SCM_REALPART SCM_REAL -#endif /* SCM_SINGLES */ - - -/* Define SCM_BIGDIG to an integer type whose size is smaller than long if - * you want bignums. SCM_BIGRAD is one greater than the biggest SCM_BIGDIG. - * - * Define SCM_DIGSTOOBIG if the digits equivalent to a long won't fit in a long. - */ -#ifdef BIGNUMS -# ifdef _UNICOS -# define SCM_DIGSTOOBIG -# if (1L << 31) <= SCM_USHRT_MAX -# define SCM_BIGDIG unsigned short -# else -# define SCM_BIGDIG unsigned int -# endif /* (1L << 31) <= USHRT_MAX */ -# define SCM_BITSPERDIG 32 -# else -# define SCM_BIGDIG unsigned short -# define SCM_BITSPERDIG (sizeof(SCM_BIGDIG)*SCM_CHAR_BIT) -# endif /* def _UNICOS */ - -# define SCM_BIGRAD (1L << SCM_BITSPERDIG) -# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) -# define SCM_DIGSPERLONGLONG ((scm_sizet)((sizeof(long long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) -# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG) -# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG) -# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG) -# define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1)) -#endif /* def BIGNUMS */ - -#ifndef SCM_BIGDIG -/* Definition is not really used but helps various function - * prototypes to compile with conditionalization. - */ -# define SCM_BIGDIG unsigned short -# define SCM_NO_BIGDIG -# ifndef SCM_FLOATS -# define SCM_INUMS_ONLY -# endif /* ndef SCM_FLOATS */ -#endif /* ndef SCM_BIGDIG */ - -#ifdef SCM_FLOATS -#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x))) -#else -#ifdef SCM_BIGDIG -#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x))) -#else -#define SCM_NUMBERP SCM_INUMP -#endif -#endif -#define SCM_NUMP(x) ((0xfcff & (int)SCM_CAR(x))==scm_tc7_smob) -#define SCM_BIGP(x) (SCM_TYP16S(x)==scm_tc16_bigpos) -#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x)) -#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x))) -#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16)) -#define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t)) - - -#ifdef SCM_FLOATS -typedef struct scm_dblproc -{ - char *scm_string; - double (*cproc) (); -} scm_dblproc; - -#ifdef SCM_SINGLES -typedef struct scm_flo -{ - SCM type; - float num; -} scm_flo; -#endif - -typedef struct scm_dbl -{ - SCM type; - double *real; -} scm_dbl; -#endif - - - - - -extern SCM scm_exact_p SCM_P ((SCM x)); -extern SCM scm_odd_p SCM_P ((SCM n)); -extern SCM scm_even_p SCM_P ((SCM n)); -extern SCM scm_abs SCM_P ((SCM x)); -extern SCM scm_quotient SCM_P ((SCM x, SCM y)); -extern SCM scm_remainder SCM_P ((SCM x, SCM y)); -extern SCM scm_modulo SCM_P ((SCM x, SCM y)); -extern SCM scm_gcd SCM_P ((SCM x, SCM y)); -extern SCM scm_lcm SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logand SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logior SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logxor SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logtest SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logbit_p SCM_P ((SCM n1, SCM n2)); -extern SCM scm_lognot SCM_P ((SCM n)); -extern SCM scm_integer_expt SCM_P ((SCM z1, SCM z2)); -extern SCM scm_ash SCM_P ((SCM n, SCM cnt)); -extern SCM scm_bit_extract SCM_P ((SCM n, SCM start, SCM end)); -extern SCM scm_logcount SCM_P ((SCM n)); -extern SCM scm_integer_length SCM_P ((SCM n)); -extern SCM scm_mkbig SCM_P ((scm_sizet nlen, int sign)); -extern SCM scm_big2inum SCM_P ((SCM b, scm_sizet l)); -extern SCM scm_adjbig SCM_P ((SCM b, scm_sizet nlen)); -extern SCM scm_normbig SCM_P ((SCM b)); -extern SCM scm_copybig SCM_P ((SCM b, int sign)); -extern SCM scm_long2big SCM_P ((long n)); -extern SCM scm_long_long2big SCM_P ((long_long n)); -extern SCM scm_2ulong2big SCM_P ((unsigned long * np)); -extern SCM scm_ulong2big SCM_P ((unsigned long n)); -extern int scm_bigcomp SCM_P ((SCM x, SCM y)); -extern long scm_pseudolong SCM_P ((long x)); -extern void scm_longdigs SCM_P ((long x, SCM_BIGDIG digs[])); -extern SCM scm_addbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny)); -extern SCM scm_mulbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn)); -extern unsigned int scm_divbigdig SCM_P ((SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div)); -extern SCM scm_divbigint SCM_P ((SCM x, long z, int sgn, int mode)); -extern SCM scm_divbigbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes)); -extern scm_sizet scm_iint2str SCM_P ((long num, int rad, char *p)); -extern SCM scm_number_to_string SCM_P ((SCM x, SCM radix)); -extern int scm_floprint SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); -extern int scm_bigprint SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_istr2int SCM_P ((char *str, long len, long radix)); -extern SCM scm_istr2flo SCM_P ((char *str, long len, long radix)); -extern SCM scm_istring2number SCM_P ((char *str, long len, long radix)); -extern SCM scm_string_to_number SCM_P ((SCM str, SCM radix)); -extern SCM scm_makdbl SCM_P ((double x, double y)); -extern SCM scm_bigequal SCM_P ((SCM x, SCM y)); -extern SCM scm_floequal SCM_P ((SCM x, SCM y)); -extern SCM scm_number_p SCM_P ((SCM x)); -extern SCM scm_real_p SCM_P ((SCM x)); -extern SCM scm_integer_p SCM_P ((SCM x)); -extern SCM scm_inexact_p SCM_P ((SCM x)); -extern SCM scm_num_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_zero_p SCM_P ((SCM z)); -extern SCM scm_positive_p SCM_P ((SCM x)); -extern SCM scm_negative_p SCM_P ((SCM x)); -extern SCM scm_max SCM_P ((SCM x, SCM y)); -extern SCM scm_min SCM_P ((SCM x, SCM y)); -extern SCM scm_sum SCM_P ((SCM x, SCM y)); -extern SCM scm_difference SCM_P ((SCM x, SCM y)); -extern SCM scm_product SCM_P ((SCM x, SCM y)); -extern double scm_num2dbl SCM_P ((SCM a, char * why)); -extern SCM scm_divide SCM_P ((SCM x, SCM y)); -extern double scm_asinh SCM_P ((double x)); -extern double scm_acosh SCM_P ((double x)); -extern double scm_atanh SCM_P ((double x)); -extern double scm_truncate SCM_P ((double x)); -extern double scm_round SCM_P ((double x)); -extern double scm_exact_to_inexact SCM_P ((double z)); -extern SCM scm_sys_expt SCM_P ((SCM z1, SCM z2)); -extern SCM scm_sys_atan2 SCM_P ((SCM z1, SCM z2)); -extern SCM scm_make_rectangular SCM_P ((SCM z1, SCM z2)); -extern SCM scm_make_polar SCM_P ((SCM z1, SCM z2)); -extern SCM scm_real_part SCM_P ((SCM z)); -extern SCM scm_imag_part SCM_P ((SCM z)); -extern SCM scm_magnitude SCM_P ((SCM z)); -extern SCM scm_angle SCM_P ((SCM z)); -extern SCM scm_inexact_to_exact SCM_P ((SCM z)); -extern SCM scm_trunc SCM_P ((SCM x)); -extern SCM scm_dbl2big SCM_P ((double d)); -extern double scm_big2dbl SCM_P ((SCM b)); -extern SCM scm_long2num SCM_P ((long sl)); -extern SCM scm_long_long2num SCM_P ((long_long sl)); -extern SCM scm_ulong2num SCM_P ((unsigned long sl)); -extern long scm_num2long SCM_P ((SCM num, char *pos, char *s_caller)); -extern long num2long SCM_P ((SCM num, char *pos, char *s_caller)); -extern long_long scm_num2long_long SCM_P ((SCM num, char *pos, char *s_caller)); -extern unsigned long scm_num2ulong SCM_P ((SCM num, char *pos, char *s_caller)); -extern void scm_init_numbers SCM_P ((void)); - -#endif /* NUMBERSH */ diff --git a/libguile/objprop.c b/libguile/objprop.c deleted file mode 100644 index f644a6694..000000000 --- a/libguile/objprop.c +++ /dev/null @@ -1,120 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "hashtab.h" -#include "alist.h" -#include "weaks.h" - -#include "objprop.h" - - -/* {Object Properties} - */ - -SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties); - -SCM -scm_object_properties (obj) - SCM obj; -{ - return scm_hashq_ref (scm_object_whash, obj, SCM_EOL); -} - - -SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x); - -SCM -scm_set_object_properties_x (obj, plist) - SCM obj; - SCM plist; -{ - SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist); - SCM_SETCDR (handle, plist); - return plist; -} - -SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property); - -SCM -scm_object_property (obj, key) - SCM obj; - SCM key; -{ - SCM assoc; - assoc = scm_assq (key, SCM_CDR (scm_object_properties (obj))); - return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); -} - -SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x); - -SCM -scm_set_object_property_x (obj, key, val) - SCM obj; - SCM key; - SCM val; -{ - SCM h; - SCM assoc; - h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL); - SCM_DEFER_INTS; - assoc = scm_assoc (key, SCM_CDR (h)); - if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, val); - else - { - assoc = scm_acons (key, val, SCM_CDR (h)); - SCM_SETCDR (h, assoc); - } - SCM_ALLOW_INTS; - return val; -} - - -void -scm_init_objprop () -{ - scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511)); -#include "objprop.x" -} - diff --git a/libguile/objprop.h b/libguile/objprop.h deleted file mode 100644 index 89a662346..000000000 --- a/libguile/objprop.h +++ /dev/null @@ -1,62 +0,0 @@ -/* classes: h_files */ - -#ifndef OBJPROPH -#define OBJPROPH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_object_properties SCM_P ((SCM obj)); -extern SCM scm_set_object_properties_x SCM_P ((SCM obj, SCM plist)); -extern SCM scm_object_property SCM_P ((SCM obj, SCM key)); -extern SCM scm_set_object_property_x SCM_P ((SCM obj, SCM key, SCM val)); -extern void scm_init_objprop SCM_P ((void)); - -#endif /* OBJPROPH */ diff --git a/libguile/options.c b/libguile/options.c deleted file mode 100644 index ade12e2ee..000000000 --- a/libguile/options.c +++ /dev/null @@ -1,227 +0,0 @@ -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "options.h" - - -/* {Run-time options} - * - * This is the basic interface for low-level configuration of the - * Guile library. It is used for configuring the reader, evaluator, - * printer and debugger. - * - * Motivation: - * - * 1. Altering option settings can have side effects. - * 2. Option values can be stored in native format. - * (Important for efficiency in, e. g., the evaluator.) - * 3. Doesn't use up name space. - * 4. Options can be naturally grouped => ease of use. - */ - -/* scm_options is the core of all options interface procedures. - * - * Some definitions: - * - * Run time options in Guile are arranged in groups. Each group - * affects a certain aspect of the behaviour of the library. - * - * An "options interface procedure" manages one group of options. It - * can be used to check or set options, or to get documentation for - * all options of a group. The options interface procedure is not - * intended to be called directly by the user. The user should - * instead call - * - * (<group>-options) - * (<group>-options 'help) - * (<group>-options 'full) - * - * to display current option settings (The second version also - * displays documentation. The third version also displays - * information about programmer's options.), and - * - * (<group>-enable '<option-symbol>) - * (<group>-disable '<option-symbol>) - * (<group>-set! <option-symbol> <value>) - * (<group>-options <option setting>) - * - * to alter the state of an option (The last version sets all - * options according to <option setting>.) where <group> is the name - * of the option group. - * - * An "option setting" represents the state of all low-level options - * managed by one options interface procedure. It is a list of - * single symbols and symbols followed by a value. - * - * For boolean options, the presence of the symbol of that option in - * the option setting indicates a true value. If the symbol isn't a - * member of the option setting this represents a false value. - * - * Other options are represented by a symbol followed by the value. - * - * If scm_options is called without arguments, the current option - * setting is returned. If the argument is an option setting, options - * are altered and the old setting is returned. If the argument isn't - * a list, a list of sublists is returned, where each sublist contains - * option name, value and documentation string. - */ - -SCM_SYMBOL (scm_yes_sym, "yes"); -SCM_SYMBOL (scm_no_sym, "no"); - - -SCM -scm_options (new_mode, options, n, s) - SCM new_mode; - scm_option options[]; - int n; - char *s; -{ - int i, docp = (!SCM_UNBNDP (new_mode) - && (SCM_IMP (new_mode) || SCM_NCONSP (new_mode))); - SCM ans = SCM_EOL, ls; - for (i = 0; i < n; ++i) - { - ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans; - switch (options[i].type) - { - case SCM_OPTION_BOOLEAN: - if (docp) - ls = scm_cons ((int) options[i].val - ? scm_yes_sym - : scm_no_sym, - ls); - break; - case SCM_OPTION_INTEGER: - ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls); - break; - case SCM_OPTION_SCM: - ls = scm_cons ((SCM) options[i].val, ls); - } - if (!((options[i].type == SCM_OPTION_BOOLEAN) - && !docp - && ! (int) options[i].val)) - ls = scm_cons ((SCM) options[i].name, ls); - ans = docp ? scm_cons (ls, ans) : ls; - } - if (!(SCM_UNBNDP (new_mode) || docp)) - { - unsigned long *flags; - flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long), - "mode buffer"); - for (i = 0; i < n; ++i) - if (options[i].type == SCM_OPTION_BOOLEAN) - flags[i] = 0; - else - flags[i] = (unsigned long) options[i].val; - while (SCM_NNULLP (new_mode)) - { - SCM_ASSERT (SCM_NIMP (new_mode) && SCM_CONSP (new_mode), - new_mode, - SCM_ARG1, - s); - for (i = 0; i < n; ++i) - if (SCM_CAR (new_mode) == (SCM) options[i].name) - switch (options[i].type) - { - case SCM_OPTION_BOOLEAN: - flags[i] = 1; - goto cont; - case SCM_OPTION_INTEGER: - new_mode = SCM_CDR (new_mode); - SCM_ASSERT (SCM_NIMP (new_mode) - && SCM_CONSP (new_mode) - && SCM_INUMP (SCM_CAR (new_mode)), - new_mode, - SCM_ARG1, - s); - flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode)); - goto cont; - case SCM_OPTION_SCM: - new_mode = SCM_CDR (new_mode); - flags[i] = SCM_CAR (new_mode); - goto cont; - } -#ifndef RECKLESS - scm_must_free ((char *) flags); - scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s); -#endif - cont: - new_mode = SCM_CDR (new_mode); - } - for (i = 0; i < n; ++i) options[i].val = flags[i]; - scm_must_free ((char *) flags); - } - return ans; -} - - -void -scm_init_opts (func, options, n) - SCM (*func) (SCM); - scm_option options[]; - int n; -{ - int i; - - for (i = 0; i < n; ++i) - { - options[i].name = (char *) SCM_CAR (scm_sysintern (options[i].name, - SCM_UNDEFINED)); - options[i].doc = (char *) scm_permanent_object (scm_take0str - (options[i].doc)); - } - func (SCM_UNDEFINED); -} - - -void -scm_init_options () -{ -#include "options.x" -} diff --git a/libguile/options.h b/libguile/options.h deleted file mode 100644 index 62b0a7436..000000000 --- a/libguile/options.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef OPTIONSH -#define OPTIONSH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -typedef struct scm_option -{ - int type; - char *name; - unsigned long val; - char *doc; -} scm_option; - -#define SCM_OPTION_BOOLEAN 0 -#define SCM_OPTION_INTEGER 1 -#define SCM_OPTION_SCM 2 - -extern SCM scm_yes_sym, scm_no_sym; - - -extern SCM scm_options SCM_P ((SCM new_mode, scm_option options[], int n, char *s)); -extern void scm_init_opts SCM_P ((SCM (*func) (SCM), scm_option options[], int n)); -extern void scm_init_options SCM_P ((void)); - -#endif /* OPTIONSH */ diff --git a/libguile/pairs.c b/libguile/pairs.c deleted file mode 100644 index 619529e64..000000000 --- a/libguile/pairs.c +++ /dev/null @@ -1,163 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" - - - -/* {Pairs} - */ - -SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons); - -SCM -scm_cons (x, y) - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - return z; -} - - -SCM -scm_cons2 (w, x, y) - SCM w; - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - x = z; - SCM_NEWCELL (z); - SCM_SETCAR (z, w); - SCM_SETCDR (z, x); - return z; -} - - -SCM_PROC(s_pair_p, "pair?", 1, 0, 0, scm_pair_p); - -SCM -scm_pair_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_CONSP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x); - -SCM -scm_set_car_x(pair, value) - SCM pair; - SCM value; -{ - SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_car_x); - SCM_SETCAR (pair, value); - return value; -} - -SCM_PROC(s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x); - -SCM -scm_set_cdr_x(pair, value) - SCM pair; - SCM value; -{ - SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_cdr_x); - SCM_SETCDR (pair, value); - return value; -} - - - - -static scm_iproc cxrs[] = -{ - {"car", 0}, - {"cdr", 0}, - {"caar", 0}, - {"cadr", 0}, - {"cdar", 0}, - {"cddr", 0}, - {"caaar", 0}, - {"caadr", 0}, - {"cadar", 0}, - {"caddr", 0}, - {"cdaar", 0}, - {"cdadr", 0}, - {"cddar", 0}, - {"cdddr", 0}, - {"caaaar", 0}, - {"caaadr", 0}, - {"caadar", 0}, - {"caaddr", 0}, - {"cadaar", 0}, - {"cadadr", 0}, - {"caddar", 0}, - {"cadddr", 0}, - {"cdaaar", 0}, - {"cdaadr", 0}, - {"cdadar", 0}, - {"cdaddr", 0}, - {"cddaar", 0}, - {"cddadr", 0}, - {"cdddar", 0}, - {"cddddr", 0}, - {0, 0} -}; - - - -void -scm_init_pairs () -{ - scm_init_iprocs(cxrs, scm_tc7_cxr); -#include "pairs.x" -} - diff --git a/libguile/pairs.h b/libguile/pairs.h deleted file mode 100644 index ec074f77b..000000000 --- a/libguile/pairs.h +++ /dev/null @@ -1,172 +0,0 @@ -/* classes: h_files */ - -#ifndef PAIRSH -#define PAIRSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -typedef struct scm_cell -{ - SCM car; - SCM cdr; -} scm_cell; - -/* SCM_PTR_LT defines how to compare two SCM_CELLPTRs (which may not be in the - * same scm_array). SCM_CELLPTR is a pointer to a cons cell which may be - * compared or differenced. SCMPTR is used for stack bounds. - */ - -#if !defined(__TURBOC__) || defined(__TOS__) - -typedef scm_cell *SCM_CELLPTR; -typedef SCM *SCMPTR; - -# ifdef nosve -# define SCM_PTR_MASK 0xffffffffffff -# define SCM_PTR_LT(x, y) (((int)(x)&SCM_PTR_MASK) < ((int)(y)&SCM_PTR_MASK)) -# else -# define SCM_PTR_LT(x, y) ((x) < (y)) -# endif /* def nosve */ - -#else /* defined(__TURBOC__) && !defined(__TOS__) */ - -# ifdef PROT386 -typedef scm_cell *SCM_CELLPTR; -typedef SCM *SCMPTR; -# define SCM_PTR_LT(x, y) (((long)(x)) < ((long)(y))) -# else -typedef scm_cell huge *SCM_CELLPTR; -typedef SCM huge *SCMPTR; -# define SCM_PTR_LT(x, y) ((x) < (y)) -# endif /* def PROT386 */ - -#endif /* defined(__TURBOC__) && !defined(__TOS__) */ - -#define SCM_PTR_GT(x, y) SCM_PTR_LT(y, x) -#define SCM_PTR_LE(x, y) (!SCM_PTR_GT(x, y)) -#define SCM_PTR_GE(x, y) (!SCM_PTR_LT(x, y)) - -#define SCM_NULLP(x) (SCM_EOL == (x)) -#define SCM_NNULLP(x) (SCM_EOL != (x)) - - - - -/* Cons Pairs - */ - -#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car) -#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr) -#define SCM_GCCDR(x) (~1L & SCM_CDR(x)) -#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v)) -#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v)) - -#define SCM_CARLOC(x) (&SCM_CAR (x)) -#define SCM_CDRLOC(x) (&SCM_CDR (x)) - -#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y)) -#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y)) -#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y)) -#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y)) - -#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) -#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) -#define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ)) -#define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ)) - -#define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ))) -#define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ))) -#define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ))) -#define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ))) -#define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ))) -#define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ))) -#define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ))) -#define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ))) - -#define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) - - -#ifdef DEBUG_FREELIST -#define SCM_NEWCELL(_into) (scm_debug_newcell (&_into)) -#else -#define SCM_NEWCELL(_into) \ - { \ - if (SCM_IMP(scm_freelist)) \ - _into = scm_gc_for_newcell();\ - else \ - { \ - _into = scm_freelist; \ - scm_freelist = SCM_CDR(scm_freelist);\ - ++scm_cells_allocated; \ - } \ - } -#endif - - - -extern SCM scm_cons SCM_P ((SCM x, SCM y)); -extern SCM scm_cons2 SCM_P ((SCM w, SCM x, SCM y)); -extern SCM scm_pair_p SCM_P ((SCM x)); -extern SCM scm_set_car_x SCM_P ((SCM pair, SCM value)); -extern SCM scm_set_cdr_x SCM_P ((SCM pair, SCM value)); -extern void scm_init_pairs SCM_P ((void)); - -#endif /* PAIRSH */ diff --git a/libguile/ports.c b/libguile/ports.c deleted file mode 100644 index c2a9406e6..000000000 --- a/libguile/ports.c +++ /dev/null @@ -1,854 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "chars.h" - -#include "markers.h" -#include "filesys.h" -#include "fports.h" -#include "strports.h" -#include "vports.h" - -#include "ports.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef HAVE_SYS_IOCTL_H -#include <sys/ioctl.h> -#endif - - - -/* scm_ptobs scm_numptob - * implement a dynamicly resized array of ptob records. - * Indexes into this table are used when generating type - * tags for smobjects (if you know a tag you can get an index and conversely). - */ -scm_ptobfuns *scm_ptobs; -scm_sizet scm_numptob; - - -SCM -scm_markstream (ptr) - SCM ptr; -{ - int openp; - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - openp = SCM_CAR (ptr) & SCM_OPN; - SCM_SETGC8MARK (ptr); - if (openp) - return SCM_STREAM (ptr); - else - return SCM_BOOL_F; -} - - - -long -scm_newptob (ptob) - scm_ptobfuns *ptob; -{ - char *tmp; - if (255 <= scm_numptob) - goto ptoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); - if (tmp) - { - scm_ptobs = (scm_ptobfuns *) tmp; - scm_ptobs[scm_numptob].mark = ptob->mark; - scm_ptobs[scm_numptob].free = ptob->free; - scm_ptobs[scm_numptob].print = ptob->print; - scm_ptobs[scm_numptob].equalp = ptob->equalp; - scm_ptobs[scm_numptob].fputc = ptob->fputc; - scm_ptobs[scm_numptob].fputs = ptob->fputs; - scm_ptobs[scm_numptob].fwrite = ptob->fwrite; - scm_ptobs[scm_numptob].fflush = ptob->fflush; - scm_ptobs[scm_numptob].fgetc = ptob->fgetc; - scm_ptobs[scm_numptob].fclose = ptob->fclose; - scm_numptob++; - } - SCM_ALLOW_INTS; - if (!tmp) - ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); - return scm_tc7_port + (scm_numptob - 1) * 256; -} - - -/* internal SCM call */ - -void -scm_fflush (port) - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - (scm_ptobs[i].fflush) (SCM_STREAM (port)); -} - - - -SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p); - -SCM -scm_char_ready_p (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p); - if (SCM_CRDYP (port) || !SCM_FPORTP (port)) - return SCM_BOOL_T; - return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - -SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p); - -SCM -scm_ungetc_char_ready_p (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p); - return (SCM_CRDYP (port) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - -/* {Standard Ports} - */ -SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); - -SCM -scm_current_input_port () -{ - return scm_cur_inp; -} - -SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); - -SCM -scm_current_output_port () -{ - return scm_cur_outp; -} - -SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); - -SCM -scm_current_error_port () -{ - return scm_cur_errp; -} - -SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); - -SCM -scm_set_current_input_port (port) - SCM port; -{ - SCM oinp = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); - scm_cur_inp = port; - return oinp; -} - - -SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); - -SCM -scm_set_current_output_port (port) - SCM port; -{ - SCM ooutp = scm_cur_outp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); - scm_cur_outp = port; - return ooutp; -} - - -SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); - -SCM -scm_set_current_error_port (port) - SCM port; -{ - SCM oerrp = scm_cur_errp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); - scm_cur_errp = port; - return oerrp; -} - - - -/* {Ports - in general} - * - */ - -/* Array of open ports, required for reliable MOVE->FDES etc. */ -struct scm_port_table **scm_port_table; - -int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ -int scm_port_table_room = 20; /* Size of the array. */ - -/* Add a port to the table. Call with SCM_DEFER_INTS active. */ - -struct scm_port_table * -scm_add_to_port_table (port) - SCM port; -{ - if (scm_port_table_size == scm_port_table_room) - { - scm_port_table = ((struct scm_port_table **) - realloc ((char *) scm_port_table, - (long) (sizeof (struct scm_port_table) - * scm_port_table_room * 2))); - /* !!! error checking */ - scm_port_table_room *= 2; - } - scm_port_table[scm_port_table_size] = ((struct scm_port_table *) - scm_must_malloc (sizeof (struct scm_port_table), - "system port table")); - scm_port_table[scm_port_table_size]->port = port; - scm_port_table[scm_port_table_size]->revealed = 0; - scm_port_table[scm_port_table_size]->stream = 0; - scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; - scm_port_table[scm_port_table_size]->line_number = 1; - scm_port_table[scm_port_table_size]->column_number = 0; - scm_port_table[scm_port_table_size]->representation = scm_regular_port; - return scm_port_table[scm_port_table_size++]; -} - -/* Remove a port from the table. Call with SCM_DEFER_INTS active. */ - -void -scm_remove_from_port_table (port) - SCM port; -{ - int i = 0; - while (scm_port_table[i]->port != port) - { - i++; - /* Error if not found: too violent? May occur in GC. */ - if (i >= scm_port_table_size) - scm_wta (port, "Port not in table", "scm_remove_from_port_table"); - } - scm_must_free ((char *)scm_port_table[i]); - scm_mallocated -= sizeof (*scm_port_table[i]); - scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; - SCM_SETPTAB_ENTRY (port, 0); - scm_port_table_size--; -} - -#ifdef DEBUG -/* Undocumented functions for debugging. */ -/* Return the number of ports in the table. */ -static char s_pt_size[] = "pt-size"; - -SCM -scm_pt_size () -{ - return SCM_MAKINUM (scm_port_table_size); -} - -/* Return the ith member of the port table. */ -static char s_pt_member[] = "pt-member"; - -SCM -scm_pt_member (member) - SCM member; -{ - int i; - SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); - i = SCM_INUM (member); - if (i < 0 || i >= scm_port_table_size) - return SCM_BOOL_F; - else - return scm_port_table[i]->port; -} -#endif - - -/* Find a port in the table and return its revealed count. - Also used by the garbage collector. - */ - -int -scm_revealed_count (port) - SCM port; -{ - return SCM_REVEALED(port); -} - - - -/* Return the revealed count for a port. */ - -SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); - -SCM -scm_port_revealed (port) - SCM port; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); - return SCM_MAKINUM (scm_revealed_count (port)); -} - -/* Set the revealed count for a port. */ -SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); - -SCM -scm_set_port_revealed_x (port, rcount) - SCM port; - SCM rcount; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); - SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); - SCM_DEFER_INTS; - SCM_REVEALED (port) = SCM_INUM (rcount); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -/* scm_close_port - * Call the close operation on a port object. - */ -SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); - -SCM -scm_close_port (port) - SCM port; -{ - scm_sizet i; - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port); - if (SCM_CLOSEDP (port)) - return SCM_UNSPECIFIED; - i = SCM_PTOBNUM (port); - SCM_DEFER_INTS; - if (scm_ptobs[i].fclose) - SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port))); - scm_remove_from_port_table (port); - SCM_SETAND_CAR (port, ~SCM_OPN); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); - -SCM -scm_close_all_ports_except (ports) - SCM ports; -{ - int i = 0; - SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); - SCM_DEFER_INTS; - while (i < scm_port_table_size) - { - SCM thisport = scm_port_table[i]->port; - int found = 0; - SCM ports_ptr = ports; - - while (SCM_NNULLP (ports_ptr)) - { - SCM port = SCM_CAR (ports_ptr); - if (i == 0) - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); - if (port == thisport) - found = 1; - ports_ptr = SCM_CDR (ports_ptr); - } - if (found) - i++; - else - /* i is not to be incremented here. */ - scm_close_port (thisport); - } - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); - -SCM -scm_input_port_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); - -SCM -scm_output_port_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); - -SCM -scm_eof_object_p (x) - SCM x; -{ - return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); - -SCM -scm_force_output (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output); - { - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port))); - return SCM_UNSPECIFIED; - } -} - - -SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); - -SCM -scm_read_char (port) - SCM port; -{ - int c; - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - return SCM_MAKICHR (c); -} - - -SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); - -SCM -scm_peek_char (port) - SCM port; -{ - int c; - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - scm_gen_ungetc (c, port); - return SCM_MAKICHR (c); -} - -SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); - -SCM -scm_unread_char (cobj, port) - SCM cobj; - SCM port; -{ - int c; - - SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); - - - c = SCM_ICHR (cobj); - - scm_gen_ungetc (c, port); - return cobj; -} - - - -SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line); - -SCM -scm_port_line (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_MAKINUM (SCM_LINUM (p)); -} - -SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x); - -SCM -scm_set_port_line_x (port, line) - SCM port; - SCM line; -{ - if (line == SCM_UNDEFINED) - { - line = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_line_x); - return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); -} - -SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column); - -SCM -scm_port_column (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_MAKINUM (SCM_COL (p)); -} - -SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x); - -SCM -scm_set_port_column_x (port, column) - SCM port; - SCM column; -{ - if (column == SCM_UNDEFINED) - { - column = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_column_x); - return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); -} - -SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename); - -SCM -scm_port_filename (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_PTAB_ENTRY (p)->file_name; -} - -SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x); - -SCM -scm_set_port_filename_x (port, filename) - SCM port; - SCM filename; -{ - if (filename == SCM_UNDEFINED) - { - filename = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_filename_x); - return SCM_PTAB_ENTRY (port)->file_name = filename; -} - -#ifndef ttyname -extern char * ttyname(); -#endif - - -void -scm_prinport (exp, port, type) - SCM exp; - SCM port; - char *type; -{ - scm_gen_puts (scm_regular_string, "#<", port); - if (SCM_CLOSEDP (exp)) - scm_gen_puts (scm_regular_string, "closed: ", port); - else - { - if (SCM_RDNG & SCM_CAR (exp)) - scm_gen_puts (scm_regular_string, "input: ", port); - if (SCM_WRTNG & SCM_CAR (exp)) - scm_gen_puts (scm_regular_string, "output: ", port); - } - scm_gen_puts (scm_regular_string, type, port); - scm_gen_putc (' ', port); -#ifndef MSDOS -#ifndef __EMX__ -#ifndef _DCC -#ifndef AMIGA -#ifndef THINK_C - if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) - scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); - else -#endif -#endif -#endif -#endif -#endif - if (SCM_OPFPORTP (exp)) - scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); - else - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); -} - - -void -scm_ports_prehistory () -{ - scm_numptob = 0; - scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); - - /* WARNING: These scm_newptob calls must be done in this order. - * They must agree with the port declarations in tags.h. - */ - /* scm_tc16_fport = */ scm_newptob (&scm_fptob); - /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); - /* scm_tc16_strport = */ scm_newptob (&scm_stptob); - /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); -} - - - -/* {Void Ports} - */ - -int scm_tc16_void_port = 0; - -static int -print_void_port (exp, port, writing) - SCM exp; - SCM port; - int writing; -{ - scm_prinport (exp, port, "void"); - return 1; -} - -static int -putc_void_port (c, strm) - int c; - SCM strm; -{ - return 0; /* vestigial return value */ -} - -static int -puts_void_port (s, strm) - char * s; - SCM strm; -{ - return 0; /* vestigial return value */ -} - -static scm_sizet -write_void_port (ptr, size, nitems, strm) - void * ptr; - int size; - int nitems; - SCM strm; -{ - int len; - len = size * nitems; - return len; -} - - -static int flush_void_port SCM_P ((SCM strm)); - -static int -flush_void_port (strm) - SCM strm; -{ - return 0; -} - - -static int getc_void_port SCM_P ((SCM strm)); - -static int -getc_void_port (strm) - SCM strm; -{ - return EOF; -} - - -static int close_void_port SCM_P ((SCM strm)); - -static int -close_void_port (strm) - SCM strm; -{ - return 0; /* this is ignored by scm_close_port. */ -} - - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -static struct scm_ptobfuns void_port_ptob = -{ - scm_mark0, - noop0, - print_void_port, - 0, /* equal? */ - putc_void_port, - puts_void_port, - write_void_port, - flush_void_port, - getc_void_port, - close_void_port, -}; - - - - -SCM -scm_void_port (mode_str) - char * mode_str; -{ - int mode_bits; - SCM answer; - struct scm_port_table * pt; - - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - mode_bits = scm_mode_bits (mode_str); - pt = scm_add_to_port_table (answer); - SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); - SCM_SETPTAB_ENTRY (answer, pt); - SCM_SETSTREAM (answer, SCM_BOOL_F); - SCM_ALLOW_INTS; - return answer; -} - - -SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); - -SCM -scm_sys_make_void_port (mode) - SCM mode; -{ - SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode, - SCM_ARG1, s_sys_make_void_port); - - return scm_void_port (SCM_ROCHARS (mode)); -} - - - - - - -void -scm_init_ports () -{ - scm_tc16_void_port = scm_newptob (&void_port_ptob); -#include "ports.x" -} - diff --git a/libguile/ports.h b/libguile/ports.h deleted file mode 100644 index 55875b197..000000000 --- a/libguile/ports.h +++ /dev/null @@ -1,200 +0,0 @@ -/* classes: h_files */ - -#ifndef PORTSH -#define PORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -enum scm_port_representation_type -{ - scm_regular_port, - scm_mb_port, - scm_wchar_port -}; - -enum scm_string_representation_type -{ - scm_regular_string = scm_regular_port, - scm_mb_string = scm_mb_port, - scm_wchar_string = scm_wchar_port -}; - - -struct scm_port_table -{ - SCM port; /* Open port. */ - int revealed; /* 0 not revealed, > 1 revealed. - * Revealed ports do not get GC'd. - */ - - SCM stream; - SCM file_name; /* debugging support. */ - int unchr; /* pushed back character, if any */ - - int line_number; /* debugging support. */ - int column_number; /* debugging support. */ - - enum scm_port_representation_type representation; -}; - -extern struct scm_port_table **scm_port_table; -extern int scm_port_table_size; /* Number of ports in scm_port_table. */ - - - - -/* PORT FLAGS - * A set of flags characterizes a port. - */ -#define SCM_OPN (1L<<16) /* Is the port open? */ -#define SCM_RDNG (2L<<16) /* Is it a readable port? */ -#define SCM_WRTNG (4L<<16) /* Is it writable? */ -#define SCM_BUF0 (8L<<16) -#define SCM_CRDY (32L<<16) /* Should char-ready? return #t? */ - -/* A mask used to clear the char-ready port flag. */ -#define SCM_CUC 0x001fffffL - -#define SCM_PORTP(x) (SCM_TYP7(x)==scm_tc7_port) -#define SCM_OPPORTP(x) (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) -#define SCM_OPINPORTP(x) (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) -#define SCM_OPOUTPORTP(x) (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) -#define SCM_FPORTP(x) (SCM_TYP16S(x)==scm_tc7_port) -#define SCM_OPFPORTP(x) (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) -#define SCM_OPINFPORTP(x) (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) -#define SCM_OPOUTFPORTP(x) (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) - -#define SCM_INPORTP(x) (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG)) -#define SCM_OUTPORTP(x) (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG)) -#define SCM_OPENP(x) (SCM_OPN & SCM_CAR(x)) -#define SCM_CLOSEDP(x) (!SCM_OPENP(x)) -#define SCM_PTAB_ENTRY(x) ((struct scm_port_table *)SCM_CDR(x)) -#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent)) -#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream -#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s) -#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name -#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number -#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number -#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed -#define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s) -#define SCM_PORT_REPRESENTATION(x) SCM_PTAB_ENTRY(x)->representation -#define SCM_SET_PORT_REPRESENTATION(x,s) (SCM_PTAB_ENTRY(x)->representation = s) -#define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY) -#define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);} -#define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);} -#define SCM_CUNGET(c,port) {SCM_PTAB_ENTRY(port)->unchr = c; SCM_SETRDY(port);} -#define SCM_CGETUN(port) (SCM_PTAB_ENTRY(port)->unchr) - -#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} -#define SCM_INCCOL(port) {SCM_COL (port) += 1;} -#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;} - - - - - -typedef struct scm_ptobfuns -{ - SCM (*mark) SCM_P ((SCM)); - int (*free) SCM_P ((SCM)); - int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - SCM (*equalp) SCM_P ((SCM, SCM)); - int (*fputc) SCM_P ((int, SCM stream)); - int (*fputs) SCM_P ((char *, SCM stream)); - scm_sizet (*fwrite) SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM stream)); - int (*fflush) SCM_P ((SCM stream)); - int (*fgetc) SCM_P ((SCM stream)); - int (*fclose) SCM_P ((SCM stream)); -} scm_ptobfuns; - -#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); - - - -extern scm_ptobfuns *scm_ptobs; -extern scm_sizet scm_numptob; -extern int scm_port_table_room; - - - -extern SCM scm_markstream SCM_P ((SCM ptr)); -extern long scm_newptob SCM_P ((scm_ptobfuns *ptob)); -extern void scm_fflush SCM_P ((SCM port)); -extern SCM scm_char_ready_p SCM_P ((SCM port)); -extern SCM scm_ungetc_char_ready_p SCM_P ((SCM port)); -extern SCM scm_current_input_port SCM_P ((void)); -extern SCM scm_current_output_port SCM_P ((void)); -extern SCM scm_current_error_port SCM_P ((void)); -extern SCM scm_set_current_input_port SCM_P ((SCM port)); -extern SCM scm_set_current_output_port SCM_P ((SCM port)); -extern SCM scm_set_current_error_port SCM_P ((SCM port)); -extern struct scm_port_table * scm_add_to_port_table SCM_P ((SCM port)); -extern void scm_remove_from_port_table SCM_P ((SCM port)); -extern SCM scm_pt_size SCM_P ((void)); -extern SCM scm_pt_member SCM_P ((SCM member)); -extern int scm_revealed_count SCM_P ((SCM port)); -extern SCM scm_port_revealed SCM_P ((SCM port)); -extern SCM scm_set_port_revealed_x SCM_P ((SCM port, SCM rcount)); -extern SCM scm_close_port SCM_P ((SCM port)); -extern SCM scm_close_all_ports_except SCM_P ((SCM ports)); -extern SCM scm_input_port_p SCM_P ((SCM x)); -extern SCM scm_output_port_p SCM_P ((SCM x)); -extern SCM scm_eof_object_p SCM_P ((SCM x)); -extern SCM scm_force_output SCM_P ((SCM port)); -extern SCM scm_read_char SCM_P ((SCM port)); -extern SCM scm_peek_char SCM_P ((SCM port)); -extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port)); -extern SCM scm_port_line SCM_P ((SCM port)); -extern SCM scm_port_column SCM_P ((SCM port)); -extern SCM scm_port_filename SCM_P ((SCM port)); -extern SCM scm_set_port_filename_x SCM_P ((SCM port, SCM filename)); -extern void scm_prinport SCM_P ((SCM exp, SCM port, char *type)); -extern void scm_ports_prehistory SCM_P ((void)); -extern SCM scm_void_port SCM_P ((char * mode_str)); -extern SCM scm_sys_make_void_port SCM_P ((SCM mode)); -extern void scm_init_ports SCM_P ((void)); - -#endif /* PORTSH */ diff --git a/libguile/posix.c b/libguile/posix.c deleted file mode 100644 index ebdbf202c..000000000 --- a/libguile/posix.c +++ /dev/null @@ -1,1461 +0,0 @@ -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "fports.h" -#include "genio.h" -#include "scmsigs.h" -#include "read.h" -#include "unif.h" -#include "feature.h" -#include "sequences.h" - -#include "posix.h" - - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -#ifndef ttyname -extern char *ttyname(); -#endif -#endif - -#ifdef LIBC_H_WITH_UNISTD_H -#include <libc.h> -#endif - -#ifdef HAVE_SYS_SELECT_H -#include <sys/select.h> -#endif - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -#include <pwd.h> - -#if HAVE_SYS_WAIT_H -# include <sys/wait.h> -#endif -#ifndef WEXITSTATUS -# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) -#endif -#ifndef WIFEXITED -# define WIFEXITED(stat_val) (((stat_val) & 255) == 0) -#endif - -#include <signal.h> - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ - -extern FILE *popen (); -extern char ** environ; - -#include <grp.h> -#include <sys/utsname.h> - -#if HAVE_DIRENT_H -# include <dirent.h> -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include <sys/ndir.h> -# endif -# if HAVE_SYS_DIR_H -# include <sys/dir.h> -# endif -# if HAVE_NDIR_H -# include <ndir.h> -# endif -#endif - -char *strptime (); - -#ifdef HAVE_SETLOCALE -#include <locale.h> -#endif - -/* Some Unix systems don't define these. CPP hair is dangerous, but - this seems safe enough... */ -#ifndef R_OK -#define R_OK 4 -#endif - -#ifndef W_OK -#define W_OK 2 -#endif - -#ifndef X_OK -#define X_OK 1 -#endif - -#ifndef F_OK -#define F_OK 0 -#endif - -/* On NextStep, <utime.h> doesn't define struct utime, unless we - #define _POSIX_SOURCE before #including it. I think this is less - of a kludge than defining struct utimbuf ourselves. */ -#ifdef UTIMBUF_NEEDS_POSIX -#define _POSIX_SOURCE -#endif - -#ifdef HAVE_SYS_UTIME_H -#include <sys/utime.h> -#endif - -#ifdef HAVE_UTIME_H -#include <utime.h> -#endif - -/* Please don't add any more #includes or #defines here. The hack - above means that _POSIX_SOURCE may be #defined, which will - encourage header files to do strange things. */ - - - - -SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe); - -SCM -scm_pipe () -{ - int fd[2], rv; - FILE *f_rd, *f_wt; - SCM p_rd, p_wt; - struct scm_port_table * ptr; - struct scm_port_table * ptw; - - SCM_NEWCELL (p_rd); - SCM_NEWCELL (p_wt); - rv = pipe (fd); - if (rv) - scm_syserror (s_pipe); - f_rd = fdopen (fd[0], "r"); - if (!f_rd) - { - SCM_SYSCALL (close (fd[0])); - SCM_SYSCALL (close (fd[1])); - scm_syserror (s_pipe); - } - f_wt = fdopen (fd[1], "w"); - if (!f_wt) - { - int en; - en = errno; - fclose (f_rd); - SCM_SYSCALL (close (fd[1])); - errno = en; - scm_syserror (s_pipe); - } - ptr = scm_add_to_port_table (p_rd); - ptw = scm_add_to_port_table (p_wt); - SCM_SETPTAB_ENTRY (p_rd, ptr); - SCM_SETPTAB_ENTRY (p_wt, ptw); - SCM_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r")); - SCM_SETCAR (p_wt, scm_tc16_fport | scm_mode_bits ("w")); - SCM_SETSTREAM (p_rd, (SCM)f_rd); - SCM_SETSTREAM (p_wt, (SCM)f_wt); - - SCM_ALLOW_INTS; - return scm_cons (p_rd, p_wt); -} - - - -SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups); - -SCM -scm_getgroups() -{ - SCM grps, ans; - int ngroups = getgroups (0, NULL); - if (!ngroups) - scm_syserror (s_getgroups); - SCM_NEWCELL(grps); - SCM_DEFER_INTS; - { - GETGROUPS_T *groups; - int val; - - groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T), - s_getgroups); - val = getgroups(ngroups, groups); - if (val < 0) - { - scm_must_free((char *)groups); - scm_syserror (s_getgroups); - } - SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ - SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - SCM_ALLOW_INTS; - ans = scm_make_vector(SCM_MAKINUM(ngroups), SCM_UNDEFINED, SCM_BOOL_F); - while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); - SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ - return ans; - } -} - - - -SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid); - -SCM -scm_getpwuid (user) - SCM user; -{ - SCM result; - struct passwd *entry; - SCM *ve; - - result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - if (SCM_UNBNDP (user) || SCM_FALSEP (user)) - { - SCM_DEFER_INTS; - SCM_SYSCALL (entry = getpwent ()); - } - else if (SCM_INUMP (user)) - { - SCM_DEFER_INTS; - entry = getpwuid (SCM_INUM (user)); - } - else - { - SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); - if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); - SCM_DEFER_INTS; - entry = getpwnam (SCM_ROCHARS (user)); - } - if (!entry) - scm_syserror (s_getpwuid); - - ve[0] = scm_makfrom0str (entry->pw_name); - ve[1] = scm_makfrom0str (entry->pw_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid); - ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid); - ve[4] = scm_makfrom0str (entry->pw_gecos); - if (!entry->pw_dir) - ve[5] = scm_makfrom0str (""); - else - ve[5] = scm_makfrom0str (entry->pw_dir); - if (!entry->pw_shell) - ve[6] = scm_makfrom0str (""); - else - ve[6] = scm_makfrom0str (entry->pw_shell); - SCM_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent); - -SCM -scm_setpwent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endpwent (); - else - setpwent (); - return SCM_UNSPECIFIED; -} - - - -/* Combines getgrgid and getgrnam. */ -SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid); - -SCM -scm_getgrgid (name) - SCM name; -{ - SCM result; - struct group *entry; - SCM *ve; - result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - SCM_DEFER_INTS; - if (SCM_UNBNDP (name) || (name == SCM_BOOL_F)) - SCM_SYSCALL (entry = getgrent ()); - else if (SCM_INUMP (name)) - SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); - else - { - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_getgrgid); - if (SCM_SUBSTRP (name)) - name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0); - SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name))); - } - if (!entry) - scm_syserror (s_getgrgid); - - ve[0] = scm_makfrom0str (entry->gr_name); - ve[1] = scm_makfrom0str (entry->gr_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); - ve[3] = scm_makfromstrs (-1, entry->gr_mem); - SCM_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent); - -SCM -scm_setgrent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endgrent (); - else - setgrent (); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill); - -SCM -scm_kill (pid, sig) - SCM pid; - SCM sig; -{ - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill); - SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill); - /* Signal values are interned in scm_init_posix(). */ - if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - scm_syserror (s_kill); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid); - -SCM -scm_waitpid (pid, options) - SCM pid; - SCM options; -{ -#ifdef HAVE_WAITPID - int i; - int status; - int ioptions; - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid); - if (SCM_UNBNDP (options)) - ioptions = 0; - else - { - SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid); - /* Flags are interned in scm_init_posix. */ - ioptions = SCM_INUM (options); - } - SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); - if (i == -1) - scm_syserror (s_waitpid); - return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); -#else - scm_sysmissing (s_waitpid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - - -SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); - -SCM -scm_getppid () -{ - return SCM_MAKINUM (0L + getppid ()); -} - - - -SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); - -SCM -scm_getuid () -{ - return SCM_MAKINUM (0L + getuid ()); -} - - - -SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); - -SCM -scm_getgid () -{ - return SCM_MAKINUM (0L + getgid ()); -} - - - -SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); - -SCM -scm_geteuid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + geteuid ()); -#else - return SCM_MAKINUM (0L + getuid ()); -#endif -} - - - -SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid); - -SCM -scm_getegid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + getegid ()); -#else - return SCM_MAKINUM (0L + getgid ()); -#endif -} - - -SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid); - -SCM -scm_setuid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid); - if (setuid (SCM_INUM (id)) != 0) - scm_syserror (s_setuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid); - -SCM -scm_setgid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid); - if (setgid (SCM_INUM (id)) != 0) - scm_syserror (s_setgid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid); - -SCM -scm_seteuid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid); -#ifdef HAVE_SETEUID - rv = seteuid (SCM_INUM (id)); -#else - rv = setuid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_seteuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid); - -SCM -scm_setegid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid); -#ifdef HAVE_SETEUID - rv = setegid (SCM_INUM (id)); -#else - rv = setgid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_setegid); - return SCM_UNSPECIFIED; - -} - -SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); -SCM -scm_getpgrp () -{ - int (*fn)(); - fn = (int (*) ()) getpgrp; - return SCM_MAKINUM (fn (0)); -} - -SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid); -SCM -scm_setpgid (pid, pgid) - SCM pid, pgid; -{ -#ifdef HAVE_SETPGID - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); - /* FIXME(?): may be known as setpgrp. */ - if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) - scm_syserror (s_setpgid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setpgid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid); -SCM -scm_setsid () -{ -#ifdef HAVE_SETSID - pid_t sid = setsid (); - if (sid == -1) - scm_syserror (s_setsid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setsid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname); - -SCM -scm_ttyname (port) - SCM port; -{ - char *ans; - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); - if (scm_tc16_fport != SCM_TYP16 (port)) - return SCM_BOOL_F; - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_ttyname); - SCM_SYSCALL (ans = ttyname (fd)); - if (!ans) - scm_syserror (s_ttyname); - /* ans could be overwritten by another call to ttyname */ - return (scm_makfrom0str (ans)); -} - - -SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid); -SCM -scm_ctermid () -{ -#ifdef HAVE_CTERMID - char *result = ctermid (NULL); - if (*result == '\0') - scm_syserror (s_ctermid); - return scm_makfrom0str (result); -#else - scm_sysmissing (s_ctermid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); -SCM -scm_tcgetpgrp (port) - SCM port; -{ -#ifdef HAVE_TCGETPGRP - int fd; - pid_t pgid; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) - scm_syserror (s_tcgetpgrp); - return SCM_MAKINUM (pgid); -#else - scm_sysmissing (s_tcgetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); -SCM -scm_tcsetpgrp (port, pgid) - SCM port, pgid; -{ -#ifdef HAVE_TCSETPGRP - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) - scm_syserror (s_tcsetpgrp); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_tcsetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -/* Copy exec args from an SCM vector into a new C array. */ - -static char ** scm_convert_exec_args SCM_P ((SCM args)); - -static char ** -scm_convert_exec_args (args) - SCM args; -{ - char **execargv; - int num_args; - int i; - SCM_DEFER_INTS; - num_args = scm_ilength (args); - execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname); - for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) - { - scm_sizet len; - char *dst; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args), - "wrong type in SCM_ARG", "exec arg"); - len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, s_ttyname); - src = SCM_ROCHARS (SCM_CAR (args)); - while (len--) - dst[len] = src[len]; - execargv[i] = dst; - } - execargv[i] = 0; - SCM_ALLOW_INTS; - return execargv; -} - -SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl); - -SCM -scm_execl (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execv (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execl); - /* not reached. */ - return SCM_BOOL_F; -} - -SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp); - -SCM -scm_execlp (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execlp); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execvp (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execlp); - /* not reached. */ - return SCM_BOOL_F; -} - -/* Flushing streams etc., is not done here. */ -SCM_PROC (s_fork, "fork", 0, 0, 0, scm_fork); - -SCM -scm_fork() -{ - int pid; - pid = fork (); - if (pid == -1) - scm_syserror (s_fork); - return SCM_MAKINUM (0L+pid); -} - - -SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname); - -SCM -scm_uname () -{ -#ifdef HAVE_UNAME - struct utsname buf; - SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - if (uname (&buf)) - return SCM_MAKINUM (errno); - ve[0] = scm_makfrom0str (buf.sysname); - ve[1] = scm_makfrom0str (buf.nodename); - ve[2] = scm_makfrom0str (buf.release); - ve[3] = scm_makfrom0str (buf.version); - ve[4] = scm_makfrom0str (buf.machine); -/* - a linux special? - ve[5] = scm_makfrom0str (buf.domainname); -*/ - return ans; -#else - scm_sysmissing (s_uname); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); - -SCM -scm_environ (env) - SCM env; -{ - if (SCM_UNBNDP (env)) - return scm_makfromstrs (-1, environ); - else - { - int num_strings; - char **new_environ; - int i = 0; - SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), - env, SCM_ARG1, s_environ); - num_strings = scm_ilength (env); - new_environ = (char **) scm_must_malloc ((num_strings + 1) - * sizeof (char *), - s_environ); - while (SCM_NNULLP (env)) - { - int len; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) && SCM_ROSTRINGP (SCM_CAR (env)), env, SCM_ARG1, - s_environ); - len = 1 + SCM_ROLENGTH (SCM_CAR (env)); - new_environ[i] = scm_must_malloc ((long) len, s_environ); - src = SCM_ROCHARS (SCM_CAR (env)); - while (len--) - new_environ[i][len] = src[len]; - env = SCM_CDR (env); - i++; - } - new_environ[i] = 0; - /* Free the old environment, except when called for the first - * time. - */ - { - char **ep; - static int first = 1; - if (!first) - { - for (ep = environ; *ep != NULL; ep++) - scm_must_free (*ep); - scm_must_free ((char *) environ); - } - first = 0; - } - environ = new_environ; - return SCM_UNSPECIFIED; - } -} - -#ifdef L_tmpnam - -SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam); - -SCM scm_tmpnam() -{ - char name[L_tmpnam]; - SCM_SYSCALL (tmpnam (name);); - return scm_makfrom0str (name); -} -#endif - -SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); - -SCM -scm_open_pipe (pipestr, modes) - SCM pipestr; - SCM modes; -{ - FILE *f; - register SCM z; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe); - if (SCM_SUBSTRP (pipestr)) - pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - scm_ignore_signals (); - SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); - scm_unignore_signals (); - if (!f) - scm_syserror (s_open_pipe); - pt = scm_add_to_port_table (z); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN - | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG)); - SCM_SETSTREAM (z, (SCM)f); - SCM_ALLOW_INTS; - return z; -} - - -SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe); - -SCM -scm_open_input_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0)); -} - -SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe); - -SCM -scm_open_output_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0)); -} - - -SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); - -SCM -scm_utime (pathname, actime, modtime) - SCM pathname; - SCM actime; - SCM modtime; -{ - int rv; - struct utimbuf utm_tmp; - - SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_utime); - - if (SCM_UNBNDP (actime)) - SCM_SYSCALL (time (&utm_tmp.actime)); - else - utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime); - - if (SCM_UNBNDP (modtime)) - SCM_SYSCALL (time (&utm_tmp.modtime)); - else - utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime); - - SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp)); - if (rv != 0) - scm_syserror (s_utime); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_access, "access?", 2, 0, 0, scm_access); - -SCM -scm_access (path, how) - SCM path; - SCM how; -{ - int rv; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_access); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access); - rv = access (SCM_ROCHARS (path), SCM_INUM (how)); - return rv ? SCM_BOOL_F : SCM_BOOL_T; -} - -SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); - -SCM -scm_getpid () -{ - return SCM_MAKINUM ((unsigned long) getpid ()); -} - -SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv); - -SCM -scm_putenv (str) - SCM str; -{ -#ifdef HAVE_PUTENV - int rv; - - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv); - rv = putenv (SCM_CHARS (str)); - if (rv < 0) - scm_syserror (s_putenv); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_putenv); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line); - -SCM -scm_read_line (port, include_terminator) - SCM port; - SCM include_terminator; -{ - register int c; - register int j = 0; - scm_sizet len = 30; - SCM tok_buf; - register char *p; - int include; - - tok_buf = scm_makstr ((long) len, 0); - p = SCM_CHARS (tok_buf); - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line); - - if (SCM_UNBNDP (include_terminator)) - include = 0; - else - include = SCM_NFALSEP (include_terminator); - - if (EOF == (c = scm_gen_getc (port))) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - /* fallthrough */ - case EOF: - if (len == j) - return tok_buf; - return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j)); - - default: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - c = scm_gen_getc (port); - break; - } - } -} - -SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x); - -SCM -scm_read_line_x (str, port) - SCM str; - SCM port; -{ - register int c; - register int j = 0; - register char *p; - scm_sizet len; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x); - p = SCM_CHARS (str); - len = SCM_LENGTH (str); - if SCM_UNBNDP - (port) port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - case EOF: - return SCM_MAKINUM (j); - default: - if (j >= len) - { - scm_gen_ungetc (c, port); - return SCM_BOOL_F; - } - p[j++] = c; - c = scm_gen_getc (port); - } - } -} - -SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line); - -SCM -scm_write_line (obj, port) - SCM obj; - SCM port; -{ - scm_display (obj, port); - return scm_newline (port); -} - -SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale); - -SCM -scm_setlocale (category, locale) - SCM category; - SCM locale; -{ -#ifdef HAVE_SETLOCALE - char *clocale; - char *rv; - - SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale); - if (SCM_UNBNDP (locale)) - { - clocale = NULL; - } - else - { - SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale); - clocale = SCM_CHARS (locale); - } - - rv = setlocale (SCM_INUM (category), clocale); - if (rv == NULL) - scm_syserror (s_setlocale); - return scm_makfrom0str (rv); -#else - scm_sysmissing (s_setlocale); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); - -SCM -scm_strftime (format, stime) - SCM format; - SCM stime; -{ - struct tm t; - - char *tbuf; - int n; - int size = 50; - char *fmt; - int len; - - SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime); - SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9, - stime, SCM_ARG2, s_strftime); - - fmt = SCM_ROCHARS (format); - len = SCM_ROLENGTH (format); - -#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime) - n = 0; - t.tm_sec = tm_deref; - t.tm_min = tm_deref; - t.tm_hour = tm_deref; - t.tm_mday = tm_deref; - t.tm_mon = tm_deref; - t.tm_year = tm_deref; - /* not used by mktime. - t.tm_wday = tm_deref; - t.tm_yday = tm_deref; */ - t.tm_isdst = tm_deref; -#undef tm_deref - - /* fill in missing fields and set the timezone. */ - mktime (&t); - - tbuf = scm_must_malloc (size, s_strftime); - while ((len = strftime (tbuf, size, fmt, &t)) == size) - { - scm_must_free (tbuf); - size *= 2; - tbuf = scm_must_malloc (size, s_strftime); - } - return scm_makfromstr (tbuf, len, 0); -} - -SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); - -SCM -scm_strptime (format, string) - SCM format; - SCM string; -{ -#ifdef HAVE_STRPTIME - SCM stime; - struct tm t; - - char *fmt, *str, *rest; - int n; - - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_strptime); - if (SCM_SUBSTRP (format)) - format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0); - SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_strptime); - if (SCM_SUBSTRP (string)) - string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0); - - fmt = SCM_CHARS (format); - str = SCM_CHARS (string); - - /* initialize the struct tm */ -#define tm_init(field) t.field = 0 - tm_init (tm_sec); - tm_init (tm_min); - tm_init (tm_hour); - tm_init (tm_mday); - tm_init (tm_mon); - tm_init (tm_year); - tm_init (tm_wday); - tm_init (tm_yday); - tm_init (tm_isdst); -#undef tm_init - - SCM_DEFER_INTS; - rest = strptime (str, fmt, &t); - SCM_ALLOW_INTS; - - if (rest == NULL) - scm_syserror (s_strptime); - - stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED); - -#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val)); - n = 0; - stime_set (tm_sec); - stime_set (tm_min); - stime_set (tm_hour); - stime_set (tm_mday); - stime_set (tm_mon); - stime_set (tm_year); - stime_set (tm_wday); - stime_set (tm_yday); - stime_set (tm_isdst); -#undef stime_set - - return scm_cons (stime, scm_makfrom0str (rest)); -#else - scm_sysmissing (s_strptime); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod); - -SCM -scm_mknod(path, mode, dev) - SCM path; - SCM mode; - SCM dev; -{ -#ifdef HAVE_MKNOD - int val; - SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_mknod); - SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_mknod); - SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_mknod); - SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev))); - if (val != 0) - scm_syserror (s_mknod); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_mknod); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice); - -SCM -scm_nice(incr) - SCM incr; -{ -#ifdef HAVE_NICE - SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice); - if (nice(SCM_INUM(incr)) != 0) - scm_syserror (s_nice); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_nice); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); - -SCM -scm_sync() -{ -#ifdef HAVE_SYNC - sync(); -#else - scm_sysmissing (s_sync); - /* not reached. */ -#endif - return SCM_BOOL_F; -} - - - - -void -scm_init_posix () -{ - scm_add_feature ("posix"); -#ifdef HAVE_GETEUID - scm_add_feature ("EIDs"); -#endif -#ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); -#endif -#ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); -#endif -#ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); -#endif -#ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); -#endif - -#ifdef EINTR - scm_sysintern ("EINTR", SCM_MAKINUM (EINTR)); -#endif - -#ifdef SIGHUP - scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP)); -#endif -#ifdef SIGINT - scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT)); -#endif -#ifdef SIGQUIT - scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT)); -#endif -#ifdef SIGILL - scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL)); -#endif -#ifdef SIGTRAP - scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP)); -#endif -#ifdef SIGABRT - scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT)); -#endif -#ifdef SIGIOT - scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT)); -#endif -#ifdef SIGBUS - scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS)); -#endif -#ifdef SIGFPE - scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE)); -#endif -#ifdef SIGKILL - scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL)); -#endif -#ifdef SIGUSR1 - scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1)); -#endif -#ifdef SIGSEGV - scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV)); -#endif -#ifdef SIGUSR2 - scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2)); -#endif -#ifdef SIGPIPE - scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE)); -#endif -#ifdef SIGALRM - scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM)); -#endif -#ifdef SIGTERM - scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM)); -#endif -#ifdef SIGSTKFLT - scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT)); -#endif -#ifdef SIGCHLD - scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD)); -#endif -#ifdef SIGCONT - scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT)); -#endif -#ifdef SIGSTOP - scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP)); -#endif -#ifdef SIGTSTP - scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP)); -#endif -#ifdef SIGTTIN - scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN)); -#endif -#ifdef SIGTTOU - scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU)); -#endif -#ifdef SIGIO - scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO)); -#endif -#ifdef SIGPOLL - scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL)); -#endif -#ifdef SIGURG - scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG)); -#endif -#ifdef SIGXCPU - scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU)); -#endif -#ifdef SIGXFSZ - scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ)); -#endif -#ifdef SIGVTALRM - scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM)); -#endif -#ifdef SIGPROF - scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF)); -#endif -#ifdef SIGWINCH - scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH)); -#endif -#ifdef SIGLOST - scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST)); -#endif -#ifdef SIGPWR - scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR)); -#endif - /* access() symbols. */ - scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); - scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); - scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); - scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); - -#ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); -#endif -#ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); -#endif -#ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); -#endif -#ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); -#endif -#ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); -#endif -#ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); -#endif -#ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); -#endif -#include "posix.x" -} diff --git a/libguile/posix.h b/libguile/posix.h deleted file mode 100644 index 1dd9eb52d..000000000 --- a/libguile/posix.h +++ /dev/null @@ -1,101 +0,0 @@ -/* classes: h_files */ - -#ifndef POSIXH -#define POSIXH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_tcsetpgrp SCM_P ((SCM port, SCM pgid)); -extern SCM scm_tcgetpgrp SCM_P ((SCM port)); -extern SCM scm_ctermid SCM_P ((void)); -extern SCM scm_setsid SCM_P ((void)); -extern SCM scm_setpgid SCM_P ((SCM pid, SCM pgid)); -extern SCM scm_pipe SCM_P ((void)); -extern SCM scm_getgroups SCM_P ((void)); -extern SCM scm_getpgrp SCM_P ((void)); -extern SCM scm_getpwuid SCM_P ((SCM user)); -extern SCM scm_setpwent SCM_P ((SCM arg)); -extern SCM scm_getgrgid SCM_P ((SCM name)); -extern SCM scm_setgrent SCM_P ((SCM arg)); -extern SCM scm_kill SCM_P ((SCM pid, SCM sig)); -extern SCM scm_waitpid SCM_P ((SCM pid, SCM options)); -extern SCM scm_getppid SCM_P ((void)); -extern SCM scm_getuid SCM_P ((void)); -extern SCM scm_getgid SCM_P ((void)); -extern SCM scm_geteuid SCM_P ((void)); -extern SCM scm_getegid SCM_P ((void)); -extern SCM scm_setuid SCM_P ((SCM id)); -extern SCM scm_setgid SCM_P ((SCM id)); -extern SCM scm_seteuid SCM_P ((SCM id)); -extern SCM scm_setegid SCM_P ((SCM id)); -extern SCM scm_ttyname SCM_P ((SCM port)); -extern SCM scm_execl SCM_P ((SCM args)); -extern SCM scm_execlp SCM_P ((SCM args)); -extern SCM scm_fork SCM_P ((void)); -extern SCM scm_uname SCM_P ((void)); -extern SCM scm_environ SCM_P ((SCM env)); -extern SCM scm_open_pipe SCM_P ((SCM pipestr, SCM modes)); -extern SCM scm_open_input_pipe SCM_P ((SCM pipestr)); -extern SCM scm_open_output_pipe SCM_P ((SCM pipestr)); -extern SCM scm_utime SCM_P ((SCM pathname, SCM actime, SCM modtime)); -extern SCM scm_access SCM_P ((SCM path, SCM how)); -extern SCM scm_getpid SCM_P ((void)); -extern SCM scm_putenv SCM_P ((SCM str)); -extern SCM scm_read_line SCM_P ((SCM port, SCM include_terminator)); -extern SCM scm_read_line_x SCM_P ((SCM str, SCM port)); -extern SCM scm_write_line SCM_P ((SCM obj, SCM port)); -extern SCM scm_setlocale SCM_P ((SCM category, SCM locale)); -extern SCM scm_strftime SCM_P ((SCM format, SCM stime)); -extern SCM scm_strptime SCM_P ((SCM format, SCM string)); -extern SCM scm_mknod SCM_P ((SCM path, SCM mode, SCM dev)); -extern SCM scm_nice SCM_P ((SCM incr)); -extern SCM scm_sync SCM_P ((void)); -extern void scm_init_posix SCM_P ((void)); - -#endif /* POSIXH */ diff --git a/libguile/print.c b/libguile/print.c deleted file mode 100644 index adc70482c..000000000 --- a/libguile/print.c +++ /dev/null @@ -1,860 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "genio.h" -#include "mbstrings.h" -#include "smob.h" -#include "eval.h" -#include "procprop.h" -#include "read.h" -#include "weaks.h" -#include "unif.h" -#include "alist.h" -#include "struct.h" - -#include "print.h" - - -/* {Names of immediate symbols} - * - * This table must agree with the declarations in scm.h: {Immediate Symbols}. - */ - -char *scm_isymnames[] = -{ - /* This table must agree with the declarations */ - "#@and", - "#@begin", - "#@case", - "#@cond", - "#@do", - "#@if", - "#@lambda", - "#@let", - "#@let*", - "#@letrec", - "#@or", - "#@quote", - "#@set!", - "#@define", -#if 0 - "#@literal-variable-ref", - "#@literal-variable-set!", -#endif - "#@apply", - "#@call-with-current-continuation", - - /* user visible ISYMS */ - /* other keywords */ - /* Flags */ - - "#f", - "#t", - "#<undefined>", - "#<eof>", - "()", - "#<unspecified>" -}; - -scm_option scm_print_opts[] = { - { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F, - "Hook for printing closures." }, - { SCM_OPTION_BOOLEAN, "source", 0, - "Print closures with source." } -}; - -SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options); - -SCM -scm_print_options (setting) - SCM setting; -{ - SCM ans = scm_options (setting, - scm_print_opts, - SCM_N_PRINT_OPTIONS, - s_print_options); - return ans; -} - - -/* {Printing of Scheme Objects} - */ - -/* Detection of circular references. - * - * Due to other constraints in the implementation, this code has bad - * time complexity (O (depth * N)), The printer code will be - * completely rewritten before next release of Guile. The new code - * will be O(N). - */ -#define PUSH_REF(pstate, obj) \ -{ \ - pstate->ref_stack[pstate->top++] = (obj); \ - if (pstate->top == pstate->ceiling) \ - grow_ref_stack (pstate); \ -} - -#define ENTER_NESTED_DATA(pstate, obj, label) \ -{ \ - register int i; \ - for (i = 0; i < pstate->top; ++i) \ - if (pstate->ref_stack[i] == (obj)) \ - goto label; \ - if (pstate->fancyp) \ - { \ - if (pstate->top - pstate->list_offset >= pstate->level) \ - { \ - scm_gen_putc ('#', port); \ - return; \ - } \ - } \ - PUSH_REF(pstate, obj); \ -} \ - -#define EXIT_NESTED_DATA(pstate) { --pstate->top; } - -static SCM print_state_pool; - -#if 1 /* Used for debugging purposes */ -SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate); - -SCM -scm_current_pstate () -{ - return SCM_CADR (print_state_pool); -} -#endif - -#define PSTATE_SIZE 50L - -static SCM make_print_state SCM_P ((void)); - -static SCM -make_print_state () -{ - SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */ - SCM_INUM0, - SCM_EOL); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE), - SCM_UNDEFINED, - SCM_UNDEFINED); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = SCM_LENGTH (pstate->ref_vect); - return print_state; -} - -SCM -scm_make_print_state () -{ - SCM answer = 0; - - /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - { - answer = SCM_CADR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); - } - SCM_ALLOW_INTS; - - return answer ? answer : make_print_state (); -} - -void -scm_free_print_state (print_state) - SCM print_state; -{ - SCM handle; - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - /* Cleanup before returning print state to pool. - * It is better to do it here. Doing it in scm_prin1 - * would cost more since that function is called much more - * often. - */ - pstate->fancyp = 0; - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - SCM_SETCAR (handle, print_state); - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; -} - -static void grow_ref_stack SCM_P ((scm_print_state *pstate)); - -static void -grow_ref_stack (pstate) - scm_print_state *pstate; -{ - int new_size = 2 * pstate->ceiling; - scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size)); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = new_size; -} - - -static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref)); - -static void -print_circref (port, pstate, ref) - SCM port; - scm_print_state *pstate; - SCM ref; -{ - register int i; - int self = pstate->top - 1; - i = pstate->top - 1; - if (SCM_CONSP (pstate->ref_stack[i])) - { - while (i > 0) - { - if (SCM_NCONSP (pstate->ref_stack[i - 1]) - || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i]) - break; - --i; - } - self = i; - } - for (i = pstate->top - 1; 1; --i) - if (pstate->ref_stack[i] == ref) - break; - scm_gen_putc ('#', port); - scm_intprint (i - self, 10, port); - scm_gen_putc ('#', port); -} - -/* Print generally. Handles both write and display according to PSTATE. - */ - - -void -scm_iprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - register long i; -taloop: - switch (7 & (int) exp) - { - case 2: - case 6: - scm_intprint (SCM_INUM (exp), 10, port); - break; - case 4: - if (SCM_ICHRP (exp)) - { - i = SCM_ICHR (exp); - scm_put_wchar (i, port, SCM_WRITINGP (pstate)); - - } - else if (SCM_IFLAGP (exp) - && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) - scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port); - else if (SCM_ILOCP (exp)) - { - scm_gen_puts (scm_regular_string, "#@", port); - scm_intprint ((long) SCM_IFRAME (exp), 10, port); - scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port); - scm_intprint ((long) SCM_IDIST (exp), 10, port); - } - else - goto idef; - break; - case 1: - /* gloc */ - scm_gen_puts (scm_regular_string, "#@", port); - exp = SCM_CAR (exp - 1); - goto taloop; - default: - idef: - scm_ipruk ("immediate", exp, port); - break; - case 0: - switch (SCM_TYP7 (exp)) - { - case scm_tcs_cons_gloc: - - if (SCM_CDR (SCM_CAR (exp) - 1L) == 0) - { - scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port); - scm_intprint(exp, 16, port); - scm_gen_putc ('>', port); - break; - } - - case scm_tcs_cons_imcar: - case scm_tcs_cons_nimcar: - ENTER_NESTED_DATA (pstate, exp, circref); - scm_iprlist ("(", exp, ')', port, pstate); - EXIT_NESTED_DATA (pstate); - break; - circref: - print_circref (port, pstate, exp); - break; - case scm_tcs_closures: - if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))) - { - SCM ans = scm_cons2 (exp, port, - scm_cons (SCM_WRITINGP (pstate) - ? SCM_BOOL_T - : SCM_BOOL_F, - SCM_EOL)); - ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL); - } - else - { - SCM name, code; - name = scm_procedure_property (exp, scm_i_name); - code = SCM_CODE (exp); - scm_gen_puts (scm_regular_string, "#<procedure ", port); - if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) - { - scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); - scm_gen_putc (' ', port); - } - scm_iprin1 (SCM_CAR (code), port, pstate); - if (SCM_PRINT_SOURCE_P) - { - code = scm_unmemocopy (SCM_CDR (code), - SCM_EXTEND_ENV (SCM_CAR (code), - SCM_EOL, - SCM_ENV (exp))); - ENTER_NESTED_DATA (pstate, exp, circref); - scm_iprlist (" ", code, '>', port, pstate); - EXIT_NESTED_DATA (pstate); - } - else - scm_gen_putc ('>', port); - } - break; - case scm_tc7_mb_string: - case scm_tc7_mb_substring: - scm_print_mb_string (exp, port, SCM_WRITINGP (pstate)); - break; - case scm_tc7_substring: - case scm_tc7_string: - if (SCM_WRITINGP (pstate)) - { - scm_gen_putc ('"', port); - for (i = 0; i < SCM_ROLENGTH (exp); ++i) - switch (SCM_ROCHARS (exp)[i]) - { - case '"': - case '\\': - scm_gen_putc ('\\', port); - default: - scm_gen_putc (SCM_ROCHARS (exp)[i], port); - } - scm_gen_putc ('"', port); - break; - } - else - scm_gen_write (scm_regular_string, SCM_ROCHARS (exp), - (scm_sizet) SCM_ROLENGTH (exp), - port); - break; - case scm_tcs_symbols: - if (SCM_MB_STRINGP (exp)) - { - scm_print_mb_symbol (exp, port); - break; - } - else - { - int pos; - int end; - int len; - char * str; - int weird; - int maybe_weird; - int mw_pos = 0; - - len = SCM_LENGTH (exp); - str = SCM_CHARS (exp); - scm_remember (&exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - if (len == 0) - scm_gen_write (scm_regular_string, "#{}#", 4, port); - - for (end = pos; end < len; ++end) - switch (str[end]) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_gen_write (scm_regular_string, "#{", 2, port); - weird = 1; - } - if (pos < end) - { - scm_gen_write (scm_regular_string, str + pos, end - pos, port); - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_gen_write (scm_regular_string, buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - if (pos < end) - scm_gen_write (scm_regular_string, str + pos, end - pos, port); - if (weird) - scm_gen_write (scm_regular_string, "}#", 2, port); - break; - } - case scm_tc7_wvect: - ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_IS_WHVEC (exp)) - scm_gen_puts (scm_regular_string, "#wh(", port); - else - scm_gen_puts (scm_regular_string, "#w(", port); - goto common_vector_printer; - - case scm_tc7_vector: - ENTER_NESTED_DATA (pstate, exp, circref); - scm_gen_puts (scm_regular_string, "#(", port); - common_vector_printer: - for (i = 0; i + 1 < SCM_LENGTH (exp); ++i) - { - /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); - scm_gen_putc (' ', port); - } - if (i < SCM_LENGTH (exp)) - { - /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); - } - scm_gen_putc (')', port); - EXIT_NESTED_DATA (pstate); - break; - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_svect: - case scm_tc7_ivect: - case scm_tc7_uvect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - scm_raprin1 (exp, port, pstate); - break; - case scm_tcs_subrs: - scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port); - scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp)) - ? scm_mb_string - : scm_regular_string), - SCM_CHARS (SCM_SNAME (exp)), port); - scm_gen_putc ('>', port); - break; -#ifdef CCLO - case scm_tc7_cclo: - scm_gen_puts (scm_regular_string, "#<compiled-closure ", port); - scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate); - scm_gen_putc ('>', port); - break; -#endif - case scm_tc7_contin: - scm_gen_puts (scm_regular_string, "#<continuation ", port); - scm_intprint (SCM_LENGTH (exp), 10, port); - scm_gen_puts (scm_regular_string, " @ ", port); - scm_intprint ((long) SCM_CHARS (exp), 16, port); - scm_gen_putc ('>', port); - break; - case scm_tc7_port: - i = SCM_PTOBNUM (exp); - if (i < scm_numptob - && scm_ptobs[i].print - && (scm_ptobs[i].print) (exp, port, pstate)) - break; - goto punk; - case scm_tc7_smob: - ENTER_NESTED_DATA (pstate, exp, circref); - i = SCM_SMOBNUM (exp); - if (i < scm_numsmob && scm_smobs[i].print - && (scm_smobs[i].print) (exp, port, pstate)) - { - EXIT_NESTED_DATA (pstate); - break; - } - EXIT_NESTED_DATA (pstate); - default: - punk: - scm_ipruk ("type", exp, port); - } - } -} - -/* Print states are necessary for circular reference safe printing. - * They are also expensive to allocate. Therefore print states are - * kept in a pool so that they can be reused. - */ - -void -scm_prin1 (exp, port, writingp) - SCM exp; - SCM port; - int writingp; -{ - SCM handle = 0; /* Will GC protect the handle whilst unlinked */ - scm_print_state *pstate; - - /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - { - handle = SCM_CDR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); - } - SCM_ALLOW_INTS; - - if (!handle) - handle = scm_cons (make_print_state (), SCM_EOL); - - pstate = SCM_PRINT_STATE (SCM_CAR (handle)); - pstate->writingp = writingp; - scm_iprin1 (exp, port, pstate); - - /* Return print state to pool */ - SCM_DEFER_INTS; - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; -} - - -/* Print an integer. - */ - -void -scm_intprint (n, radix, port) - long n; - int radix; - SCM port; -{ - char num_buf[SCM_INTBUFLEN]; - scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port); -} - -/* Print an object of unrecognized type. - */ - -void -scm_ipruk (hdr, ptr, port) - char *hdr; - SCM ptr; - SCM port; -{ - scm_gen_puts (scm_regular_string, "#<unknown-", port); - scm_gen_puts (scm_regular_string, hdr, port); - if (SCM_CELLP (ptr)) - { - scm_gen_puts (scm_regular_string, " (0x", port); - scm_intprint (SCM_CAR (ptr), 16, port); - scm_gen_puts (scm_regular_string, " . 0x", port); - scm_intprint (SCM_CDR (ptr), 16, port); - scm_gen_puts (scm_regular_string, ") @", port); - } - scm_gen_puts (scm_regular_string, " 0x", port); - scm_intprint (ptr, 16, port); - scm_gen_putc ('>', port); -} - -/* Print a list. - */ - - -void -scm_iprlist (hdr, exp, tlr, port, pstate) - char *hdr; - SCM exp; - char tlr; - SCM port; - scm_print_state *pstate; -{ - register int i; - register SCM hare, tortoise; - int floor = pstate->top - 2; - scm_gen_puts (scm_regular_string, hdr, port); - /* CHECK_INTS; */ - if (pstate->fancyp) - goto fancy_printing; - - /* Run a hare and tortoise so that total time complexity will be - O(depth * N) instead of O(N^2). */ - hare = SCM_CDR (exp); - tortoise = exp; - while (SCM_NIMP (hare) && SCM_ECONSP (hare)) - { - if (hare == tortoise) - goto fancy_printing; - hare = SCM_CDR (hare); - if (SCM_IMP (hare) || SCM_NECONSP (hare)) - break; - hare = SCM_CDR (hare); - tortoise = SCM_CDR (tortoise); - } - - /* No cdr cycles intrinsic to this list */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) - { - if (SCM_NECONSP (exp)) - break; - for (i = floor; i >= 0; --i) - if (pstate->ref_stack[i] == exp) - goto circref; - PUSH_REF (pstate, exp); - scm_gen_putc (' ', port); - /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - } - if (SCM_NNULLP (exp)) - { - scm_gen_puts (scm_regular_string, " . ", port); - scm_iprin1 (exp, port, pstate); - } - -end: - scm_gen_putc (tlr, port); - pstate->top = floor + 2; - return; - -fancy_printing: - { - int n = pstate->length; - - scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); --n; - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) - { - if (SCM_NECONSP (exp)) - break; - for (i = 0; i < pstate->top; ++i) - if (pstate->ref_stack[i] == exp) - goto fancy_circref; - if (pstate->fancyp) - { - if (n == 0) - { - scm_gen_puts (scm_regular_string, " ...", port); - goto skip_tail; - } - else - --n; - } - PUSH_REF(pstate, exp); - ++pstate->list_offset; - scm_gen_putc (' ', port); - /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - } - } - if (SCM_NNULLP (exp)) - { - scm_gen_puts (scm_regular_string, " . ", port); - scm_iprin1 (exp, port, pstate); - } -skip_tail: - pstate->list_offset -= pstate->top - floor - 2; - goto end; - -fancy_circref: - pstate->list_offset -= pstate->top - floor - 2; - -circref: - scm_gen_puts (scm_regular_string, " . ", port); - print_circref (port, pstate, exp); - goto end; -} - - - -SCM_PROC(s_write, "write", 1, 1, 0, scm_write); - -SCM -scm_write (obj, port) - SCM obj; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write); - scm_prin1 (obj, port, 1); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_display, "display", 1, 1, 0, scm_display); - -SCM -scm_display (obj, port) - SCM obj; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display); - scm_prin1 (obj, port, 0); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline); - -SCM -scm_newline (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline); - scm_gen_putc ('\n', port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); - else -# endif -#endif - if (port == scm_cur_outp) - scm_fflush (port); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char); - -SCM -scm_write_char (chr, port) - SCM chr; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char); - scm_gen_putc ((int) SCM_ICHR (chr), port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - - - - - -void -scm_init_print () -{ - SCM vtable, type; - scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL); - type = scm_make_struct (vtable, - SCM_INUM0, - scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)), - SCM_EOL)); - print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); -#include "print.x" -} diff --git a/libguile/print.h b/libguile/print.h deleted file mode 100644 index cb326fb5b..000000000 --- a/libguile/print.h +++ /dev/null @@ -1,100 +0,0 @@ -/* classes: h_files */ - -#ifndef PRINTH -#define PRINTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/options.h" - -extern scm_option scm_print_opts[]; - -#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val) -#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) -#define SCM_N_PRINT_OPTIONS 2 - -/* State information passed around during printing. - */ -#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) - -#define RESET_PRINT_STATE(pstate) \ -{ \ - pstate->list_offset = 0; \ - pstate->top = 0; \ -} - -#define SCM_WRITINGP(pstate) ((pstate)->writingp) -#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } - -#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuruopr" -typedef struct scm_print_state { - SCM handle; /* Struct handle */ - unsigned long writingp; /* Writing? */ - unsigned long fancyp; /* Fancy printing? */ - unsigned long level; /* Max level */ - unsigned long length; /* Max number of objects per level */ - SCM hot_ref; /* Hot reference */ - unsigned long list_offset; - unsigned long top; /* Top of reference stack */ - unsigned long ceiling; /* Max size of reference stack */ - SCM *ref_stack; /* Stack of references used during - circular reference detection */ - SCM ref_vect; -} scm_print_state; - -extern SCM scm_print_options SCM_P ((SCM setting)); -SCM scm_make_print_state SCM_P ((void)); -void scm_free_print_state SCM_P ((SCM print_state)); -extern void scm_intprint SCM_P ((long n, int radix, SCM port)); -extern void scm_ipruk SCM_P ((char *hdr, SCM ptr, SCM port)); -extern void scm_iprlist SCM_P ((char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate)); -extern void scm_prin1 SCM_P ((SCM exp, SCM port, int writingp)); -extern void scm_iprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_write SCM_P ((SCM obj, SCM port)); -extern SCM scm_display SCM_P ((SCM obj, SCM port)); -extern SCM scm_newline SCM_P ((SCM port)); -extern SCM scm_write_char SCM_P ((SCM chr, SCM port)); -extern void scm_init_print SCM_P ((void)); - -#endif /* PRINTH */ diff --git a/libguile/procprop.c b/libguile/procprop.c deleted file mode 100644 index 42ca7dbd9..000000000 --- a/libguile/procprop.c +++ /dev/null @@ -1,138 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "alist.h" -#include "eval.h" - -#include "procprop.h" - - -static SCM -scm_stand_in_scm_proc(proc) - SCM proc; -{ - SCM answer; - answer = scm_assoc (proc, scm_stand_in_procs); - if (answer == SCM_BOOL_F) - { - answer = scm_closure (scm_listify (SCM_EOL, SCM_BOOL_F, SCM_UNDEFINED), - SCM_EOL); - scm_stand_in_procs = scm_cons (scm_cons (proc, answer), - scm_stand_in_procs); - } - else - answer = SCM_CDR (answer); - return answer; -} - -SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties); - -SCM -scm_procedure_properties (proc) - SCM proc; -{ - SCM_ASSERT (scm_procedure_p (proc), proc, SCM_ARG1, s_procedure_properties); - if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc))) - proc = scm_stand_in_scm_proc(proc); - return SCM_PROCPROPS (proc); -} - -SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x); - -SCM -scm_set_procedure_properties_x (proc, new_val) - SCM proc; - SCM new_val; -{ - if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc))) - proc = scm_stand_in_scm_proc(proc); - SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x); - SCM_SETPROCPROPS (proc, new_val); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property); - -SCM -scm_procedure_property (p, k) - SCM p; - SCM k; -{ - SCM assoc; - if (!(SCM_NIMP (p) && SCM_CLOSUREP (p))) - p = scm_stand_in_scm_proc(p); - SCM_ASSERT (scm_procedure_p (p), p, SCM_ARG1, s_procedure_property); - assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); - return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); -} - -SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x); - -SCM -scm_set_procedure_property_x (p, k, v) - SCM p; - SCM k; - SCM v; -{ - SCM assoc; - if (!(SCM_NIMP (p) && SCM_CLOSUREP (p))) - p = scm_stand_in_scm_proc(p); - SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x); - assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); - if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, v); - else - SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p))); - return SCM_UNSPECIFIED; -} - - - - -void -scm_init_procprop () -{ -#include "procprop.x" -} - diff --git a/libguile/procprop.h b/libguile/procprop.h deleted file mode 100644 index cac97edd1..000000000 --- a/libguile/procprop.h +++ /dev/null @@ -1,61 +0,0 @@ -/* classes: h_files */ - -#ifndef PROCPROPH -#define PROCPROPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_i_name; - - - -extern SCM scm_procedure_properties SCM_P ((SCM proc)); -extern SCM scm_set_procedure_properties_x SCM_P ((SCM proc, SCM new_val)); -extern SCM scm_procedure_property SCM_P ((SCM p, SCM k)); -extern SCM scm_set_procedure_property_x SCM_P ((SCM p, SCM k, SCM v)); -extern void scm_init_procprop SCM_P ((void)); - -#endif /* PROCPROPH */ diff --git a/libguile/procs.c b/libguile/procs.c deleted file mode 100644 index a8ccd0979..000000000 --- a/libguile/procs.c +++ /dev/null @@ -1,199 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "procs.h" - - - -/* {Procedures} - */ - - -SCM -scm_make_subr_opt (name, type, fcn, set) - char *name; - int type; - SCM (*fcn) (); - int set; -{ - SCM symcell; - long tmp; - register SCM z; - symcell = scm_sysintern (name, SCM_UNDEFINED); - tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8); - if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org)) - tmp = 0; - SCM_NEWCELL (z); - SCM_SUBRF (z) = fcn; - SCM_SETCAR (z, tmp + type); - if (set) - SCM_SETCDR (symcell, z); - return z; -} - - - -SCM -scm_make_subr (name, type, fcn) - char *name; - int type; - SCM (*fcn) (); -{ - return scm_make_subr_opt (name, type, fcn, 1); -} - -#ifdef CCLO - -SCM -scm_makcclo (proc, len) - SCM proc; - long len; -{ - SCM s; - SCM_NEWCELL (s); - SCM_DEFER_INTS; - SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure")); - SCM_SETLENGTH (s, len, scm_tc7_cclo); - while (--len) - SCM_VELTS (s)[len] = SCM_UNSPECIFIED; - SCM_CCLO_SUBR (s) = proc; - SCM_ALLOW_INTS; - return s; -} -#endif - - - -SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p); - -SCM -scm_procedure_p (obj) - SCM obj; -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - case scm_tc7_contin: - case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif - return SCM_BOOL_T; - default: - return SCM_BOOL_F; - } - return SCM_BOOL_F; -} - -SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p); - -SCM -scm_closure_p (obj) - SCM obj; -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - return SCM_BOOL_T; - default: ; - } - return SCM_BOOL_F; -} - -#ifdef __STDC__ -SCM -scm_thunk_p (SCM obj) -#else -SCM -scm_thunk_p (obj) - SCM obj; -#endif -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - if (SCM_NULLP (SCM_CAR (SCM_CODE (obj)))) - return SCM_BOOL_T; - case scm_tc7_subr_0: - case scm_tc7_subr_1o: - case scm_tc7_lsubr: - case scm_tc7_rpsubr: - case scm_tc7_asubr: -#ifdef CCLO - case scm_tc7_cclo: -#endif - return SCM_BOOL_T; - default: - ; - } - return SCM_BOOL_F; -} - - - -void -scm_init_iprocs(subra, type) - scm_iproc *subra; - int type; -{ - for(;subra->scm_string; subra++) - scm_make_subr(subra->scm_string, - type, - subra->cproc); -} - - - - - -void -scm_init_procs () -{ -#include "procs.x" -} - diff --git a/libguile/procs.h b/libguile/procs.h deleted file mode 100644 index 50345e784..000000000 --- a/libguile/procs.h +++ /dev/null @@ -1,103 +0,0 @@ -/* classes: h_files */ - -#ifndef PROCSH -#define PROCSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -/* Subrs - */ - -typedef struct scm_subr -{ - long sname; - SCM (*cproc) (); -} scm_subr; - -typedef struct scm_iproc -{ - char *scm_string; - SCM (*cproc) (); -} scm_iproc; - -typedef struct scm_dsubr -{ - long sname; - double (*dproc) (); -} scm_dsubr; - -#define SCM_SNAME(x) ((SCM_CAR(x)>>8)?(SCM)(scm_heap_org+(SCM_CAR(x)>>8)):scm_nullstr) -#define SCM_SUBRF(x) (((scm_subr *)(SCM2PTR(x)))->cproc) -#define SCM_DSUBRF(x) (((scm_dsubr *)(SCM2PTR(x)))->dproc) -#define SCM_CCLO_SUBR(x) (SCM_VELTS(x)[0]) - -/* Closures - */ - -#define SCM_CLOSUREP(x) (SCM_TYP3(x)==scm_tc3_closure) -#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure) -#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x)) -#define SCM_PROCPROPS(x) SCM_CDR(SCM_CLOSCAR (x)) -#define SCM_SETPROCPROPS(x, p) SCM_SETCDR(SCM_CLOSCAR (x), p) -#define SCM_SETCODE(x, e) (SCM_SETCAR (x, scm_cons ((e), SCM_EOL) + scm_tc3_closure)) -#define SCM_ENV(x) SCM_CDR(x) -#define SCM_SETENV(x, e) SCM_SETCDR (x, e) -#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV)))) - - - -extern SCM scm_make_subr SCM_P ((char *name, int type, SCM (*fcn) ())); -extern SCM scm_make_subr_opt SCM_P ((char *name, int type, SCM (*fcn) (), - int set)); -extern SCM scm_makcclo SCM_P ((SCM proc, long len)); -extern SCM scm_procedure_p SCM_P ((SCM obj)); -extern SCM scm_thunk_p SCM_P ((SCM obj)); -extern void scm_init_iprocs SCM_P ((scm_iproc *subra, int type)); -extern void scm_init_procs SCM_P ((void)); - - -#endif /* PROCSH */ diff --git a/libguile/ramap.c b/libguile/ramap.c deleted file mode 100644 index a139566fc..000000000 --- a/libguile/ramap.c +++ /dev/null @@ -1,2127 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - - -#include <stdio.h> -#include "_scm.h" -#include "unif.h" -#include "smob.h" -#include "chars.h" -#include "eq.h" -#include "eval.h" -#include "feature.h" - -#include "ramap.h" - - -#ifdef ARRAYS - -typedef struct -{ - char *name; - SCM sproc; - int (*vproc) (); -} ra_iproc; - -static ra_iproc ra_rpsubrs[]; -static ra_iproc ra_asubrs[]; - -#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) -#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT))) -#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT))) - -/* Fast, recycling scm_vector ref */ -#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e)) - -/* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */ - -/* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that - elements of scm_vector operands are not aliased */ -#ifdef _UNICOS -#define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line} -#else -#define IVDEP(test, line) line -#endif - - - -/* inds must be a uvect or ivect, no check. */ - - -static scm_sizet cind SCM_P ((SCM ra, SCM inds)); - -static scm_sizet -cind (ra, inds) - SCM ra; - SCM inds; -{ - scm_sizet i; - int k; - long *ve = SCM_VELTS (inds); - if (!SCM_ARRAYP (ra)) - return *ve; - i = SCM_ARRAY_BASE (ra); - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - i += (ve[k] - SCM_ARRAY_DIMS (ra)[k].lbnd) * SCM_ARRAY_DIMS (ra)[k].inc; - return i; -} - - -/* Checker for scm_array mapping functions: - return values: 4 --> shapes, increments, and bases are the same; - 3 --> shapes and increments are the same; - 2 --> shapes are the same; - 1 --> ras are at least as big as ra0; - 0 --> no match. - */ - -int -scm_ra_matchp (ra0, ras) - SCM ra0; - SCM ras; -{ - SCM ra1; - scm_array_dim dims; - scm_array_dim *s0 = &dims; - scm_array_dim *s1; - scm_sizet bas0 = 0; - int i, ndim = 1; - int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ - if SCM_IMP - (ra0) return 0; - switch (SCM_TYP7 (ra0)) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - s0->lbnd = 0; - s0->inc = 1; - s0->ubnd = (long) SCM_LENGTH (ra0) - 1; - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - return 0; - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - break; - } - while SCM_NIMP - (ras) - { - ra1 = SCM_CAR (ras); - if SCM_IMP - (ra1) return 0; - switch SCM_TYP7 - (ra1) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - if (1 != ndim) - return 0; - switch (exact) - { - case 4: - if (0 != bas0) - exact = 3; - case 3: - if (1 != s0->inc) - exact = 2; - case 2: - if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1)) - break; - exact = 1; - case 1: - if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1)) - return 0; - } - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - if (bas0 != SCM_ARRAY_BASE (ra1)) - exact = 3; - for (i = 0; i < ndim; i++) - switch (exact) - { - case 4: - case 3: - if (s0[i].inc != s1[i].inc) - exact = 2; - case 2: - if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd) - break; - exact = 1; - default: - if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd) - return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1); - } - break; - } - ras = SCM_CDR (ras); - } - return exact; -} - -static char s_ra_mismatch[] = "array shape mismatch"; - -int -scm_ramapc (cproc, data, ra0, lra, what) - int (*cproc) (); - SCM data; - SCM ra0; - SCM lra; - char *what; -{ - SCM inds, z; - SCM vra0, ra1, vra1; - SCM lvra, *plvra; - long *vinds; - int k, kmax; - switch (scm_ra_matchp (ra0, lra)) - { - default: - case 0: - scm_wta (ra0, s_ra_mismatch, what); - case 2: - case 3: - case 4: /* Try unrolling arrays */ - kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0); - if (kmax < 0) - goto gencase; - vra0 = scm_array_contents (ra0, SCM_UNDEFINED); - if SCM_IMP - (vra0) goto gencase; - if (!SCM_ARRAYP (vra0)) - { - vra1 = scm_make_ra (1); - SCM_ARRAY_BASE (vra1) = 0; - SCM_ARRAY_DIMS (vra1)->lbnd = 0; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1; - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = vra0; - vra0 = vra1; - } - lvra = SCM_EOL; - plvra = &lvra; - for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) - { - ra1 = SCM_CAR (z); - vra1 = scm_make_ra (1); - SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; - if (!SCM_ARRAYP (ra1)) - { - SCM_ARRAY_BASE (vra1) = 0; - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = ra1; - } - else if (!SCM_ARRAY_CONTP (ra1)) - goto gencase; - else - { - SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1); - SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; - SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); - } - *plvra = scm_cons (vra1, SCM_EOL); - plvra = SCM_CDRLOC (*plvra); - } - return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); - case 1: - gencase: /* Have to loop over all dimensions. */ - vra0 = scm_make_ra (1); - if SCM_ARRAYP - (ra0) - { - kmax = SCM_ARRAY_NDIM (ra0) - 1; - if (kmax < 0) - { - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = 0; - SCM_ARRAY_DIMS (vra0)->inc = 1; - } - else - { - SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd; - SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc; - } - SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0); - SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0); - } - else - { - kmax = 0; - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1; - SCM_ARRAY_DIMS (vra0)->inc = 1; - SCM_ARRAY_BASE (vra0) = 0; - SCM_ARRAY_V (vra0) = ra0; - ra0 = vra0; - } - lvra = SCM_EOL; - plvra = &lvra; - for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) - { - ra1 = SCM_CAR (z); - vra1 = scm_make_ra (1); - SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; - if SCM_ARRAYP - (ra1) - { - if (kmax >= 0) - SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; - SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); - } - else - { - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = ra1; - } - *plvra = scm_cons (vra1, SCM_EOL); - plvra = SCM_CDRLOC (*plvra); - } - inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); - vinds = (long *) SCM_VELTS (inds); - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - SCM y = lra; - SCM_ARRAY_BASE (vra0) = cind (ra0, inds); - for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y)) - SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds); - if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) - return 0; - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1; - k--; - } - while (k >= 0); - return 1; - } -} - - -static char s_array_fill_x[]; - -int -scm_array_fill_int (ra, fill, ignore) - SCM ra; - SCM fill; - SCM ignore; -{ - scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; - long inc = SCM_ARRAY_DIMS (ra)->inc; - scm_sizet base = SCM_ARRAY_BASE (ra); - ra = SCM_ARRAY_V (ra); - switch SCM_TYP7 - (ra) - { - default: - for (i = base; n--; i += inc) - scm_array_set_x (ra, fill, SCM_MAKINUM (i)); - break; - case scm_tc7_vector: - for (i = base; n--; i += inc) - SCM_VELTS (ra)[i] = fill; - break; - case scm_tc7_string: - SCM_ASRTGO (SCM_ICHRP (fill), badarg2); - for (i = base; n--; i += inc) - SCM_CHARS (ra)[i] = SCM_ICHR (fill); - break; - case scm_tc7_bvect: - { - long *ve = (long *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra))) - { - i = base / SCM_LONG_BIT; - if (SCM_BOOL_F == fill) - { - if (base % SCM_LONG_BIT) /* leading partial word */ - ve[i++] &= ~(~0L << (base % SCM_LONG_BIT)); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = 0L; - if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ - ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); - } - else if (SCM_BOOL_T == fill) - { - if (base % SCM_LONG_BIT) - ve[i++] |= ~0L << (base % SCM_LONG_BIT); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = ~0L; - if ((base + n) % SCM_LONG_BIT) - ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); - } - else - badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x); - } - else - { - if (SCM_BOOL_F == fill) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); - else if (SCM_BOOL_T == fill) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); - else - goto badarg2; - } - break; - } - case scm_tc7_uvect: - SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2); - case scm_tc7_ivect: - SCM_ASRTGO (SCM_INUMP (fill), badarg2); - { - long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float f, *ve = (float *) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); - f = SCM_REALPART (fill); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double f, *ve = (double *) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); - f = SCM_REALPART (fill); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } - case scm_tc7_cvect: - { - double fr, fi; - double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2); - fr = SCM_REALPART (fill); - fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0); - for (i = base; n--; i += inc) - { - ve[i][0] = fr; - ve[i][1] = fi; - } - break; - } -#endif /* SCM_FLOATS */ - } - return 1; -} - -SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x); - -SCM -scm_array_fill_x (ra, fill) - SCM ra; - SCM fill; -{ - scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x); - return SCM_UNSPECIFIED; -} - - - - -static int racp SCM_P ((SCM dst, SCM src)); - -static int -racp (src, dst) - SCM dst; - SCM src; -{ - long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); - long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; - scm_sizet i_d, i_s = SCM_ARRAY_BASE (src); - dst = SCM_CAR (dst); - inc_d = SCM_ARRAY_DIMS (dst)->inc; - i_d = SCM_ARRAY_BASE (dst); - src = SCM_ARRAY_V (src); - dst = SCM_ARRAY_V (dst); - switch SCM_TYP7 - (dst) - { - default: - gencase: case scm_tc7_vector: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); - break; - case scm_tc7_string: - if (scm_tc7_string != SCM_TYP7 (dst)) - goto gencase; - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s]; - break; - case scm_tc7_bvect: - if (scm_tc7_bvect != SCM_TYP7 (dst)) - goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) - { - long *sv = (long *) SCM_VELTS (src); - long *dv = (long *) SCM_VELTS (dst); - sv += i_s / SCM_LONG_BIT; - dv += i_d / SCM_LONG_BIT; - if (i_s % SCM_LONG_BIT) - { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); - dv++; - sv++; - n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); - } - IVDEP (src != dst, - for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) - * dv = *sv;) - if (n) /* trailing partial word */ - *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); - } - else - { - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT))) - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT)); - else - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT)); - } - break; - case scm_tc7_uvect: - if (scm_tc7_uvect != SCM_TYP7 (src)) - goto gencase; - else - { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } - case scm_tc7_ivect: - if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src)) - goto gencase; - else - { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *d = (float *) SCM_VELTS (dst); - float *s = (float *) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((double *) s)[i_s];) - break; - } - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *d = (double *) SCM_VELTS (dst); - double *s = (double *) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((float *) s)[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } - break; - } - case scm_tc7_cvect: - { - double (*d)[2] = (double (*)[2]) SCM_VELTS (dst); - double (*s)[2] = (double (*)[2]) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((long *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((float *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((double *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_cvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = s[i_s][0]; - d[i_d][1] = s[i_s][1]; - } - ) - } - break; - } - } -#endif /* SCM_FLOATS */ - return 1; -} - - -SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x); -SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x); - -SCM -scm_array_copy_x (src, dst) - SCM src; - SCM dst; -{ - scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x); - return SCM_UNSPECIFIED; -} - -/* Functions callable by ARRAY-MAP! */ - - -int -scm_ra_eqp (ra0, ras) - SCM ra0; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if SCM_FALSEP - (scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) - BVE_CLR (ra0, i0); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; - case scm_tc7_cvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] || - ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_FLOATS*/ - } - return 1; -} - -/* opt 0 means <, nonzero means >= */ - -static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt)); - -static int -ra_compare (ra0, ra1, ra2, opt) - SCM ra0; - SCM ra1; - SCM ra2; - int opt; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : - SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - BVE_CLR (ra0, i0); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - { - if BVE_REF - (ra0, i0) - if (opt ? - SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : - SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); - } - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] : - ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] : - ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_FLOATS*/ - } - return 1; -} - - - -int -scm_ra_lessp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); -} - - -int -scm_ra_leqp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); -} - - -int -scm_ra_grp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); -} - - -int -scm_ra_greqp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); -} - - - -int -scm_ra_sum (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NNULLP - (ras) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] += v1[i1][0]; - v0[i0][1] += v1[i1][1]; - } - ); - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - - -int -scm_ra_difference (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - { - switch SCM_TYP7 - (ra0) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - v0[i0][0] = -v0[i0][0]; - v0[i0][1] = -v0[i0][1]; - } - break; - } -#endif /* SCM_FLOATS */ - } - } - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] -= v1[i1][0]; - v0[i0][1] -= v1[i1][1]; - } - ) - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - - -int -scm_ra_product (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NNULLP - (ras) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - register double r; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1]; - v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0]; - v0[i0][0] = r; - } - ); - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - -int -scm_ra_divide (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - { - switch SCM_TYP7 - (ra0) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } - case scm_tc7_cvect: - { - register double d; - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1]; - v0[i0][0] /= d; - v0[i0][1] /= -d; - } - break; - } -#endif /* SCM_FLOATS */ - } - } - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } - case scm_tc7_cvect: - { - register double d, r; - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1]; - r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d; - v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d; - v0[i0][0] = r; - } - ) - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - -int -scm_array_identity (dst, src) - SCM src; - SCM dst; -{ - return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); -} - - - -static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - long inc = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; - long base = SCM_ARRAY_BASE (ra0) - i * inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; i <= n; i++) - scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base)); - else - { - SCM ra1 = SCM_CAR (ras); - SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - ras = scm_nullvect; - else - { - ras = scm_vector (ras); - ve = SCM_VELTS (ras); - } - for (; i <= n; i++, i1 += inc1) - { - args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); - args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base)); - } - } - return 1; -} - - -static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_cxr (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - switch SCM_TYP7 - (ra0) - { - default: - gencase: - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *dst = (float *) SCM_VELTS (ra0); - switch SCM_TYP7 - (ra1) - { - default: - goto gencase; - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *dst = (double *) SCM_VELTS (ra0); - switch SCM_TYP7 - (ra1) - { - default: - goto gencase; - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } -#endif /* SCM_FLOATS */ - } - return 1; -} - - - -static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_rp (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if SCM_FALSEP - (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) - BVE_CLR (ra0, i0); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - if SCM_FALSEP - (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]), - SCM_MAKINUM (SCM_VELTS (ra2)[i2]))) - BVE_CLR (ra0, i0); - } - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; - SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - { - SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } - case scm_tc7_cvect: - { - SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; - SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; - SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } -#endif /*SCM_FLOATS*/ - } - return 1; -} - - - -static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_1 (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - return 1; -} - - - -static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_2o (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - { - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - } - else - { - SCM ra2 = SCM_CAR (ras); - SCM e2 = SCM_UNDEFINED; - scm_sizet i2 = SCM_ARRAY_BASE (ra2); - long inc2 = SCM_ARRAY_DIMS (ra2)->inc; - ra2 = SCM_ARRAY_V (ra2); - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - scm_array_set_x (ra0, - SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)), - SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - scm_array_set_x (ra0, - SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)), - SCM_MAKINUM (i0)); - } - return 1; -} - - - -static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_a (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - } - return 1; -} - -SCM_PROC(s_serial_array_map, "serial-array-map", 2, 0, 1, scm_array_map); -SCM_PROC(s_array_map, "array-map", 2, 0, 1, scm_array_map); - -SCM -scm_array_map (ra0, proc, lra) - SCM ra0; - SCM proc; - SCM lra; -{ - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map); - switch (SCM_TYP7 (proc)) - { - default: - gencase: - scm_ramapc (ramap, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_subr_1: - scm_ramapc (ramap_1, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_cxr: - if (!SCM_SUBRF (proc)) - goto gencase; - scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_rpsubr: - { - ra_iproc *p; - if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T))) - goto gencase; - scm_array_fill_x (ra0, SCM_BOOL_T); - for (p = ra_rpsubrs; p->name; p++) - if (proc == p->sproc) - { - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) - { - scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - case scm_tc7_asubr: - if SCM_NULLP - (lra) - { - SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); - if SCM_INUMP - (fill) - { - prot = scm_array_prototype (ra0); - if (SCM_NIMP (prot) && SCM_INEXP (prot)) - fill = scm_makdbl ((double) SCM_INUM (fill), 0.0); - } - - scm_array_fill_x (ra0, fill); - } - else - { - SCM tail, ra1 = SCM_CAR (lra); - SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0); - ra_iproc *p; - /* Check to see if order might matter. - This might be an argument for a separate - SERIAL-ARRAY-MAP! */ - if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) - goto gencase; - for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail)) - { - ra1 = SCM_CAR (tail); - if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - goto gencase; - } - for (p = ra_asubrs; p->name; p++) - if (proc == p->sproc) - { - if (ra0 != SCM_CAR (lra)) - scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map); - lra = SCM_CDR (lra); - while (1) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map); - if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) - return SCM_UNSPECIFIED; - lra = SCM_CDR (lra); - } - } - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - if SCM_NIMP - (lra) - for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) - scm_ramapc (ramap_a, proc, ra0, lra, s_array_map); - } - return SCM_UNSPECIFIED; - } -} - - -static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -rafe (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; i <= n; i++, i0 += inc0) - scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull); - else - { - SCM ra1 = SCM_CAR (ras); - SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - ras = scm_nullvect; - else - { - ras = scm_vector (ras); - ve = SCM_VELTS (ras); - } - for (; i <= n; i++, i0 += inc0, i1 += inc1) - { - args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); - args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_apply (proc, args, SCM_EOL); - } - } - return 1; -} - - -SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each); - -SCM -scm_array_for_each (proc, ra0, lra) - SCM proc; - SCM ra0; - SCM lra; -{ - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each); - scm_ramapc (rafe, proc, ra0, lra, s_array_for_each); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x); - -SCM -scm_array_index_map_x (ra, proc) - SCM ra; - SCM proc; -{ - scm_sizet i; - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x); - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_index_map_x); - switch SCM_TYP7 - (ra) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x); - case scm_tc7_vector: - { - SCM *ve = SCM_VELTS (ra); - for (i = 0; i < SCM_LENGTH (ra); i++) - ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); - return SCM_UNSPECIFIED; - } - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - for (i = 0; i < SCM_LENGTH (ra); i++) - scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i)); - return SCM_UNSPECIFIED; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - { - SCM args = SCM_EOL; - SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); - long *vinds = SCM_VELTS (inds); - int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - i = cind (ra, inds); - for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) - { - for (j = kmax + 1, args = SCM_EOL; j--;) - args = scm_cons (SCM_MAKINUM (vinds[j]), args); - scm_array_set_x (SCM_ARRAY_V (ra), scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i)); - i += SCM_ARRAY_DIMS (ra)[k].inc; - } - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1; - k--; - } - while (k >= 0); - return SCM_UNSPECIFIED; - } - } -} - - -static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - -static int -raeql_1 (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; -{ - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - scm_sizet i0 = 0, i1 = 0; - long inc0 = 1, inc1 = 1; - scm_sizet n = SCM_LENGTH (ra0); - ra1 = SCM_CAR (ra1); - if SCM_ARRAYP - (ra0) - { - n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - i0 = SCM_ARRAY_BASE (ra0); - inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - } - if SCM_ARRAYP - (ra1) - { - i1 = SCM_ARRAY_BASE (ra1); - inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - } - switch SCM_TYP7 - (ra0) - { - case scm_tc7_vector: - default: - for (; n--; i0 += inc0, i1 += inc1) - { - if SCM_FALSEP - (as_equal) - { - if SCM_FALSEP - (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))) - return 0; - } - else if SCM_FALSEP - (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))) - return 0; - } - return 1; - case scm_tc7_string: - { - char *v0 = SCM_CHARS (ra0) + i0; - char *v1 = SCM_CHARS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_bvect: - for (; n--; i0 += inc0, i1 += inc1) - if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1)) - return 0; - return 1; - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = (long *) SCM_VELTS (ra0) + i0; - long *v1 = (long *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0) + i0; - float *v1 = (float *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0) + i0; - double *v1 = (double *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - { - if ((*v0)[0] != (*v1)[0]) - return 0; - if ((*v0)[1] != (*v1)[1]) - return 0; - } - return 1; - } -#endif /* SCM_FLOATS */ - } -} - - - -static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - -static int -raeql (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; -{ - SCM v0 = ra0, v1 = ra1; - scm_array_dim dim0, dim1; - scm_array_dim *s0 = &dim0, *s1 = &dim1; - scm_sizet bas0 = 0, bas1 = 0; - int k, unroll = 1, vlen = 1, ndim = 1; - if SCM_ARRAYP - (ra0) - { - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - v0 = SCM_ARRAY_V (ra0); - } - else - { - s0->inc = 1; - s0->lbnd = 0; - s0->ubnd = SCM_LENGTH (v0) - 1; - unroll = 0; - } - if SCM_ARRAYP - (ra1) - { - if (ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - bas1 = SCM_ARRAY_BASE (ra1); - v1 = SCM_ARRAY_V (ra1); - } - else - { - if (1 != ndim) - return SCM_BOOL_F; - s1->inc = 1; - s1->lbnd = 0; - s1->ubnd = SCM_LENGTH (v1) - 1; - unroll = 0; - } - if (SCM_TYP7 (v0) != SCM_TYP7 (v1)) - return 0; - for (k = ndim; k--;) - { - if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) - return 0; - if (unroll) - { - unroll = (s0[k].inc == s1[k].inc); - vlen *= s0[k].ubnd - s1[k].lbnd + 1; - } - } - if (unroll && bas0 == bas1 && v0 == v1) - return SCM_BOOL_T; - return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), ""); -} - - -SCM -scm_raequal (ra0, ra1) - SCM ra0; - SCM ra1; -{ - return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F); -} - -static char s_array_equal_p[] = "array-equal?"; - - -SCM -scm_array_equal_p (ra0, ra1) - SCM ra0; - SCM ra1; -{ - if (SCM_IMP (ra0) || SCM_IMP (ra1)) - callequal:return scm_equal_p (ra0, ra1); - switch SCM_TYP7 - (ra0) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - goto callequal; - } - switch SCM_TYP7 - (ra1) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1)) - goto callequal; - } - return (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F); -} - - - - -/* These tables are a kluge that will not scale well when more - * vectorized subrs are added. It is tempting to steal some bits from - * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an - * offset into a table of vectorized subrs. - */ - -static ra_iproc ra_rpsubrs[] = -{ - {"=", SCM_UNDEFINED, scm_ra_eqp}, - {"<", SCM_UNDEFINED, scm_ra_lessp}, - {"<=", SCM_UNDEFINED, scm_ra_leqp}, - {">", SCM_UNDEFINED, scm_ra_grp}, - {">=", SCM_UNDEFINED, scm_ra_greqp}, - {0, 0, 0} -}; - -static ra_iproc ra_asubrs[] = -{ - {"+", SCM_UNDEFINED, scm_ra_sum}, - {"-", SCM_UNDEFINED, scm_ra_difference}, - {"*", SCM_UNDEFINED, scm_ra_product}, - {"/", SCM_UNDEFINED, scm_ra_divide}, - {0, 0, 0} -}; - -static void -init_raprocs (subra) - ra_iproc *subra; -{ - for (; subra->name; subra++) - subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); -} - - -void -scm_init_ramap () -{ - init_raprocs (ra_rpsubrs); - init_raprocs (ra_asubrs); - scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); - scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal; -#include "ramap.x" - scm_add_feature (s_array_for_each); -} - -#endif /* ARRAYS */ diff --git a/libguile/ramap.h b/libguile/ramap.h deleted file mode 100644 index da4ec2691..000000000 --- a/libguile/ramap.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef RAMAPH -#define RAMAPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern int scm_ra_matchp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ramapc SCM_P ((int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what)); -extern int scm_array_fill_int SCM_P ((SCM ra, SCM fill, SCM ignore)); -extern SCM scm_array_fill_x SCM_P ((SCM ra, SCM fill)); -extern SCM scm_array_copy_x SCM_P ((SCM src, SCM dst)); -extern int scm_ra_eqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_lessp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_leqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_grp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_greqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_sum SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_difference SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_product SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_divide SCM_P ((SCM ra0, SCM ras)); -extern int scm_array_identity SCM_P ((SCM src, SCM dst)); -extern SCM scm_array_map SCM_P ((SCM ra0, SCM proc, SCM lra)); -extern SCM scm_array_for_each SCM_P ((SCM proc, SCM ra0, SCM lra)); -extern SCM scm_array_index_map_x SCM_P ((SCM ra, SCM proc)); -extern SCM scm_raequal SCM_P ((SCM ra0, SCM ra1)); -extern SCM scm_array_equal_p SCM_P ((SCM ra0, SCM ra1)); -extern void scm_init_ramap SCM_P ((void)); - -#endif /* RAMAPH */ diff --git a/libguile/read.c b/libguile/read.c deleted file mode 100644 index 48badf976..000000000 --- a/libguile/read.c +++ /dev/null @@ -1,768 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "genio.h" -#include "eval.h" -#include "unif.h" -#include "mbstrings.h" -#include "kw.h" -#include "alist.h" -#include "srcprop.h" -#include "hashtab.h" -#include "hash.h" - -#include "read.h" - - - -#define default_case_i 0 - - - -scm_option scm_read_opts[] = { - { SCM_OPTION_BOOLEAN, "copy", 0, - "Copy source code expressions." }, - { SCM_OPTION_BOOLEAN, "positions", 0, - "Record positions of source code expressions." } -}; - -SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options); - -SCM -scm_read_options (setting) - SCM setting; -{ - SCM ans = scm_options (setting, - scm_read_opts, - SCM_N_READ_OPTIONS, - s_read_options); - if (SCM_COPY_SOURCE_P) - SCM_RECORD_POSITIONS_P = 1; - return ans; -} - -SCM_PROC (s_read, "read", 0, 3, 0, scm_read); - -SCM -scm_read (port, case_insensitive_p, sharp) - SCM port; - SCM case_insensitive_p; - SCM sharp; -{ - int c; - SCM tok_buf, copy; - int case_i; - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, - SCM_ARG1, - s_read); - - case_i = (SCM_UNBNDP (case_insensitive_p) - ? default_case_i - : (case_insensitive_p == SCM_BOOL_F)); - - if (SCM_UNBNDP (sharp)) - sharp = SCM_BOOL_F; - - c = scm_flush_ws (port, (char *) NULL); - if (EOF == c) - return SCM_EOF_VAL; - scm_gen_ungetc (c, port); - - tok_buf = scm_makstr (30L, 0); - return scm_lreadr (&tok_buf, port, case_i, sharp, ©); -} - - - -char * -scm_grow_tok_buf (tok_buf) - SCM * tok_buf; -{ - scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf))); - return SCM_CHARS (*tok_buf); -} - - - -int -scm_flush_ws (port, eoferr) - SCM port; - char *eoferr; -{ - register int c; - while (1) - switch (c = scm_gen_getc (port)) - { - case EOF: - goteof: - if (eoferr) - scm_wta (SCM_UNDEFINED, "end of file in ", eoferr); - return c; - case ';': - lp: - switch (c = scm_gen_getc (port)) - { - case EOF: - goto goteof; - default: - goto lp; - case SCM_LINE_INCREMENTORS: - break; - } - break; - case SCM_LINE_INCREMENTORS: - case SCM_SINGLE_SPACES: - case '\t': - break; - default: - return c; - } -} - - - -int -scm_casei_streq (s1, s2) - char * s1; - char * s2; -{ - while (*s1 && *s2) - if (scm_downcase((int)*s1) != scm_downcase((int)*s2)) - return 0; - else - { - ++s1; - ++s2; - } - return !(*s1 || *s2); -} - - -/* recsexpr is used when recording expressions - * constructed by read:sharp. - */ - -static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename)); - -static SCM -recsexpr (obj, line, column, filename) - SCM obj; - int line; - int column; - SCM filename; -{ - if (SCM_IMP (obj) || SCM_NCONSP(obj)) - return obj; - { - SCM tmp = obj, copy; - /* If this sexpr is visible in the read:sharp source, we want to - keep that information, so only record non-constant cons cells - which haven't previously been read by the reader. */ - if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj))) - { - if (SCM_COPY_SOURCE_P) - { - copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename), - SCM_UNDEFINED); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) - { - SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp), - line, - column, - filename), - SCM_UNDEFINED)); - copy = SCM_CDR (copy); - } - SCM_SETCDR (copy, tmp); - } - else - { - recsexpr (SCM_CAR (obj), line, column, filename); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) - recsexpr (SCM_CAR (tmp), line, column, filename); - copy = SCM_UNDEFINED; - } - scm_whash_insert (scm_source_whash, - obj, - scm_make_srcprops (line, - column, - filename, - copy, - SCM_EOL)); - } - return obj; - } -} - - -/* Consume an SCSH-style block comment. Assume that we've already - read the initial `#!', and eat characters until the matching `!#'. */ - -static void -skip_scsh_block_comment (port) - SCM port; -{ - char last_c = '\0'; - - for (;;) - { - int c = scm_gen_getc (port); - - if (c == EOF) - scm_wta (SCM_UNDEFINED, - "unterminated `#! ... !#' comment", "read"); - else if (c == '#' && last_c == '!') - return; - - last_c = c; - } -} - - -static char s_list[]="list"; - -SCM -scm_lreadr (tok_buf, port, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - int case_i; - SCM sharp; - SCM *copy; -{ - int c; - scm_sizet j; - SCM p; - -tryagain: - c = scm_flush_ws (port, s_read); - switch (c) - { - case EOF: - return SCM_EOF_VAL; - - case '(': - return SCM_RECORD_POSITIONS_P - ? scm_lreadrecparen (tok_buf, port, s_list, case_i, sharp, copy) - : scm_lreadparen (tok_buf, port, s_list, case_i, sharp, copy); - case ')': - scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); - goto tryagain; - - case '\'': - p = scm_i_quote; - goto recquote; - case '`': - p = scm_i_quasiquote; - goto recquote; - case ',': - c = scm_gen_getc (port); - if ('@' == c) - p = scm_i_uq_splicing; - else - { - scm_gen_ungetc (c, port); - p = scm_i_unquote; - } - recquote: - p = scm_cons2 (p, - scm_lreadr (tok_buf, port, case_i, sharp, copy), - SCM_EOL); - if (SCM_RECORD_POSITIONS_P) - scm_whash_insert (scm_source_whash, - p, - scm_make_srcprops (SCM_LINUM (port), - SCM_COL (port) - 1, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? (*copy = scm_cons2 (SCM_CAR (p), - SCM_CAR (SCM_CDR (p)), - SCM_EOL)) - : SCM_UNDEFINED, - SCM_EOL)); - return p; - case '#': - c = scm_gen_getc (port); - switch (c) - { - case '(': - p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy); - return SCM_NULLP (p) ? scm_nullvect : scm_vector (p); - - case 't': - case 'T': - return SCM_BOOL_T; - case 'f': - case 'F': - return SCM_BOOL_F; - - case 'b': - case 'B': - case 'o': - case 'O': - case 'd': - case 'D': - case 'x': - case 'X': - case 'i': - case 'I': - case 'e': - case 'E': - scm_gen_ungetc (c, port); - c = '#'; - goto num; - - case '!': - /* start of a shell script. Parse as a block comment, - terminated by !#, just like SCSH. */ - skip_scsh_block_comment (port); - goto tryagain; - - case '*': - j = scm_read_token (c, tok_buf, port, case_i, 0); - p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1)); - if (SCM_NFALSEP (p)) - return p; - else - goto unkshrp; - - case '{': - j = scm_read_token (c, tok_buf, port, case_i, 1); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); - - case '\\': - c = scm_gen_getc (port); - j = scm_read_token (c, tok_buf, port, case_i, 0); - if (j == 1) - return SCM_MAKICHR (c); - if (c >= '0' && c < '8') - { - p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8); - if (SCM_NFALSEP (p)) - return SCM_MAKICHR (SCM_INUM (p)); - } - for (c = 0; c < scm_n_charnames; c++) - if (scm_charnames[c] - && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf)))) - return SCM_MAKICHR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf)); - - - default: - callshrp: - if (SCM_NIMP (sharp)) - { - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; - SCM got; - got = scm_apply (sharp, - SCM_MAKICHR (c), - scm_acons (port, SCM_EOL, SCM_EOL)); - if (SCM_UNSPECIFIED == got) - goto unkshrp; - if (SCM_RECORD_POSITIONS_P) - return *copy = recsexpr (got, line, column, - SCM_FILENAME (port)); - else - return got; - } - unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", ""); - } - - case '"': - j = 0; - while ('"' != (c = scm_gen_getc (port))) - { - SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); - - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - scm_grow_tok_buf (tok_buf); - - if (c == '\\') - switch (c = scm_gen_getc (port)) - { - case '\n': - continue; - case '0': - c = '\0'; - break; - case 'f': - c = '\f'; - break; - case 'n': - c = '\n'; - break; - case 'r': - c = '\r'; - break; - case 't': - c = '\t'; - break; - case 'a': - c = '\007'; - break; - case 'v': - c = '\v'; - break; - } - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - SCM_CHARS (*tok_buf)[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (SCM_CHARS (*tok_buf) + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - if (j == 0) - return scm_nullstr; - SCM_CHARS (*tok_buf)[j] = 0; - { - SCM str; - str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0); - if (SCM_PORT_REPRESENTATION(port) != scm_regular_port) - { - SCM_SETLENGTH (str, SCM_LENGTH (str), scm_tc7_mb_string); - } - return str; - } - - case'0':case '1':case '2':case '3':case '4': - case '5':case '6':case '7':case '8':case '9': - case '.': - case '-': - case '+': - num: - j = scm_read_token (c, tok_buf, port, case_i, 0); - p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L); - if (SCM_NFALSEP (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_gen_getc (port) == '(')) - { - scm_gen_ungetc ('(', port); - c = SCM_CHARS (*tok_buf)[1]; - goto callshrp; - } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf)); - } - goto tok; - - case ':': - j = scm_read_token ('-', tok_buf, port, case_i, 0); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); - - default: - j = scm_read_token (c, tok_buf, port, case_i, 0); - /* fallthrough */ - - tok: - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); - } -} - -#ifdef _UNICOS -_Pragma ("noopt"); /* # pragma _CRI noopt */ -#endif - -scm_sizet -scm_read_token (ic, tok_buf, port, case_i, weird) - int ic; - SCM *tok_buf; - SCM port; - int case_i; - int weird; -{ - register scm_sizet j; - register int c; - register char *p; - - c = ic; - p = SCM_CHARS (*tok_buf); - - if (weird) - j = 0; - else - { - j = 0; - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - - while (1) - { - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); - c = scm_gen_getc (port); - switch (c) - { - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - if (weird) - goto default_case; - - scm_gen_ungetc (c, port); - case EOF: - eof_case: - p[j] = 0; - return j; - case '\\': - if (!weird) - goto default_case; - else - { - c = scm_gen_getc (port); - if (c == EOF) - goto eof_case; - else - goto default_case; - } - case '}': - if (!weird) - goto default_case; - - c = scm_gen_getc (port); - if (c == '#') - { - p[j] = 0; - return j; - } - else - { - scm_gen_ungetc (c, port); - c = '}'; - goto default_case; - } - - default: - default_case: - { - c = (case_i ? scm_downcase(c) : c); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - - } - } -} - -#ifdef _UNICOS -_Pragma ("opt"); /* # pragma _CRI opt */ -#endif - -SCM -scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - char *name; - int case_i; - SCM sharp; - SCM *copy; -{ - SCM tmp; - SCM tl; - SCM ans; - int c; - - c = scm_flush_ws (port, name); - if (')' == c) - return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); - closeit: - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - return ans; - } - ans = tl = scm_cons (tmp, SCM_EOL); - while (')' != (c = scm_flush_ws (port, name))) - { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - SCM_SETCDR (tl, scm_lreadr (tok_buf, port, case_i, sharp, copy)); - goto closeit; - } - SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); - tl = SCM_CDR (tl); - } - return ans; -} - - -SCM -scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - char *name; - int case_i; - SCM sharp; - SCM *copy; -{ - register int c; - register SCM tmp; - register SCM tl, tl2 = SCM_EOL; - SCM ans, ans2 = SCM_EOL; - /* Need to capture line and column numbers here. */ - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; - - c = scm_flush_ws (port, name); - if (')' == c) - return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - return ans; - } - /* Build the head of the list structure. */ - ans = tl = scm_cons (tmp, SCM_EOL); - if (SCM_COPY_SOURCE_P) - ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL); - while (')' != (c = scm_flush_ws (port, name))) - { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)); - if (SCM_COPY_SOURCE_P) - SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - goto exit; - } - tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); - if (SCM_COPY_SOURCE_P) - tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); - } -exit: - scm_whash_insert (scm_source_whash, - ans, - scm_make_srcprops (line, - column, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? *copy = ans2 - : SCM_UNDEFINED, - SCM_EOL)); - return ans; -} - - - - - - -void -scm_init_read () -{ - scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); -#include "read.x" -} diff --git a/libguile/read.h b/libguile/read.h deleted file mode 100644 index 8eef1ed24..000000000 --- a/libguile/read.h +++ /dev/null @@ -1,89 +0,0 @@ -/* classes: h_files */ - -#ifndef READH -#define READH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/options.h" - - -/* SCM_LINE_INCREMENTORS are the characters which cause the line count to - * be incremented for the purposes of error reporting. This feature - * is only used for scheme code loaded from files. - * - * SCM_WHITE_SPACES are other characters which should be treated like spaces - * in programs. - */ - -#define SCM_LINE_INCREMENTORS '\n' - -#ifdef MSDOS -# define SCM_SINGLE_SPACES ' ':case '\r':case '\f': case 26 -#else -# define SCM_SINGLE_SPACES ' ':case '\r':case '\f' -#endif - -#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t' - -extern scm_option scm_read_opts[]; - -#define SCM_COPY_SOURCE_P scm_read_opts[0].val -#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val -#define SCM_N_READ_OPTIONS 2 - - - -extern SCM scm_read_options SCM_P ((SCM setting)); -extern SCM scm_read SCM_P ((SCM port, SCM casep, SCM sharp)); -extern char * scm_grow_tok_buf SCM_P ((SCM * tok_buf)); -extern int scm_flush_ws SCM_P ((SCM port, char *eoferr)); -extern int scm_casei_streq SCM_P ((char * s1, char * s2)); -extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, int case_i, SCM sharp, SCM *copy)); -extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int case_i, int weird)); -extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); -extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); -extern void scm_init_read SCM_P ((void)); - -#endif /* READH */ diff --git a/libguile/root.c b/libguile/root.c deleted file mode 100644 index b79e7b72b..000000000 --- a/libguile/root.c +++ /dev/null @@ -1,378 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "stackchk.h" -#include "dynwind.h" -#include "eval.h" -#include "genio.h" -#include "smob.h" -#include "pairs.h" -#include "throw.h" - -#include "root.h" - - -SCM scm_sys_protects[SCM_NUM_PROTECTS]; - -long scm_tc16_root; - -#ifndef USE_THREADS -struct scm_root_state *scm_root; -#endif - - - -static SCM mark_root SCM_P ((SCM)); - -static SCM -mark_root (root) - SCM root; -{ - scm_root_state *s = SCM_ROOT_STATE (root); - SCM_SETGC8MARK (root); - scm_gc_mark (s->rootcont); - scm_gc_mark (s->dynwinds); - scm_gc_mark (s->continuation_stack); - scm_gc_mark (s->continuation_stack_ptr); - scm_gc_mark (s->progargs); - scm_gc_mark (s->exitval); - scm_gc_mark (s->cur_inp); - scm_gc_mark (s->cur_outp); - scm_gc_mark (s->cur_errp); - scm_gc_mark (s->def_inp); - scm_gc_mark (s->def_outp); - scm_gc_mark (s->def_errp); - scm_gc_mark (s->top_level_lookup_closure_var); - scm_gc_mark (s->system_transformer); - return SCM_ROOT_STATE (root) -> parent; -} - -static scm_sizet free_root SCM_P ((SCM)); - -static scm_sizet -free_root (root) - SCM root; -{ - scm_must_free ((char *) SCM_ROOT_STATE (root)); - return sizeof (scm_root_state); -} - -static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -print_root (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<root ", port); - scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port); - scm_gen_putc('>', port); - return 1; -} - -static scm_smobfuns root_smob = -{ - mark_root, - free_root, - print_root, - 0 -}; - - - -SCM -scm_make_root (parent) - SCM parent; -{ - SCM root; - scm_root_state *root_state; - - root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state), - "scm_make_root"); - if (SCM_NIMP (parent) && SCM_ROOTP (parent)) - { - memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state)); - root_state->parent = parent; - } - else - { - root_state->parent = SCM_BOOL_F; - } - SCM_NEWCELL (root); - SCM_REDEFER_INTS; - SCM_SETCAR (root, scm_tc16_root); - SCM_SETCDR (root, root_state); - root_state->handle = root; - SCM_REALLOW_INTS; - return root; -} - -/* {call-with-dynamic-root} - * - * Suspending the current thread to evaluate a thunk on the - * same C stack but under a new root. - * - * Calls to call-with-dynamic-root return exactly once (unless - * the process is somehow exitted). - */ - -/* Some questions about cwdr: - - Couldn't the body just be a closure? Do we really need to pass - args through to it? - - The semantics are a lot like catch's; in fact, we call - scm_internal_catch to take care of that part of things. Wouldn't - it be cleaner to say that uncaught throws just disappear into the - ether (or print a message to stderr), and let the caller use catch - themselves if they want to? - - -JimB */ - -#if 0 -SCM scm_exitval; /* INUM with return value */ -#endif -static int n_dynamic_roots = 0; - - -/* cwdr fills out one of these structures, and then passes a pointer - to it through scm_internal_catch to the cwdr_body and cwdr_handler - functions, to tell them how to behave. - - A cwdr is a lot like a catch, except there is no tag (all - exceptions are caught), and the body procedure takes the arguments - passed to cwdr as A1 and ARGS. */ - -struct cwdr_body_data { - - /* Arguments to pass to the cwdr body function. */ - SCM a1, args; - - /* Scheme procedure to use as body of cwdr. */ - SCM body_proc; - - /* Scheme procedure to call if a throw occurs within the cwdr. */ - SCM handler_proc; -}; - - -/* Invoke the body of a cwdr, assuming that the throw handler has - already been set up. DATA points to a struct set up by cwdr that - says what proc to call, and what args to apply it to. */ -static SCM cwdr_body SCM_P ((void *, SCM)); - -static SCM -cwdr_body (void *data, SCM jmpbuf) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->body_proc, c->a1, c->args); -} - - -/* Invoke the handler of a cwdr. DATA points to a struct set up by - cwdr that says what proc to call to handle the throw. */ -static SCM cwdr_handler SCM_P ((void *, SCM, SCM)); - -static SCM -cwdr_handler (void *data, SCM tag, SCM throw_args) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); -} - - -static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)); - -/* This is the basic code for new root creation. - * - * WARNING! The order of actions in this routine is in many ways - * critical. E. g., it is essential that an error doesn't leave Guile - * in a messed up state. */ - -static SCM -cwdr (proc, a1, args, handler, stack_start) - SCM proc; - SCM a1; - SCM args; - SCM handler; - SCM_STACKITEM *stack_start; -{ - int old_ints_disabled = scm_ints_disabled; - SCM old_rootcont, old_winds; - SCM answer; - - /* Create a fresh root continuation. - */ - { - SCM new_rootcont; - SCM_NEWCELL (new_rootcont); - SCM_REDEFER_INTS; - SCM_SETJMPBUF (new_rootcont, - scm_must_malloc ((long) sizeof (scm_contregs), - "inferior root continuation")); - SCM_SETCAR (new_rootcont, scm_tc7_contin); - SCM_DYNENV (new_rootcont) = SCM_EOL; - SCM_BASE (new_rootcont) = stack_start; - SCM_SEQ (new_rootcont) = ++n_dynamic_roots; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (new_rootcont) = 0; -#endif - old_rootcont = scm_rootcont; - scm_rootcont = new_rootcont; - SCM_REALLOW_INTS; - } - - /* Exit caller's dynamic state. - */ - old_winds = scm_dynwinds; - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (old_rootcont) = scm_last_debug_frame; - scm_last_debug_frame = 0; -#endif - - /* Catch all errors. */ - { - struct cwdr_body_data c; - - c.a1 = a1; - c.args = args; - c.body_proc = proc; - c.handler_proc = handler; - - answer = scm_internal_catch (SCM_BOOL_T, cwdr_body, cwdr_handler, &c); - } - - scm_dowinds (old_winds, - scm_ilength (old_winds)); - SCM_REDEFER_INTS; -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (old_rootcont); -#endif - scm_rootcont = old_rootcont; - SCM_REALLOW_INTS; - scm_ints_disabled = old_ints_disabled; - return answer; -} - - -SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root); -SCM -scm_call_with_dynamic_root (thunk, handler) - SCM thunk; - SCM handler; -{ - SCM_STACKITEM stack_place; - - return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place); -} - -SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root); -SCM -scm_dynamic_root () -{ - return scm_ulong2num (SCM_SEQ (scm_root->rootcont)); -} - -SCM -scm_apply_with_dynamic_root (proc, a1, args, handler) - SCM proc; - SCM a1; - SCM args; - SCM handler; -{ - SCM_STACKITEM stack_place; - return cwdr (proc, a1, args, handler, &stack_place); -} - - - -/* Call thunk(closure) underneath a top-level error handler. - * If an error occurs, pass the exitval through err_filter and return it. - * If no error occurs, return the value of thunk. - */ - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - - - -SCM -scm_call_catching_errors (thunk, err_filter, closure) - SCM (*thunk)(); - SCM (*err_filter)(); - void *closure; -{ - SCM answer; - setjmp_type i; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame; -#endif - i = setjmp (SCM_JMPBUF (scm_rootcont)); - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; - if (!i) - { - scm_gc_heap_lock = 0; - answer = thunk (closure); - } - else - { - scm_gc_heap_lock = 1; - answer = err_filter (scm_exitval, closure); - } - return answer; -} - -void -scm_init_root () -{ - scm_tc16_root = scm_newsmob (&root_smob); -#include "root.x" -} diff --git a/libguile/root.h b/libguile/root.h deleted file mode 100644 index 37857d47d..000000000 --- a/libguile/root.h +++ /dev/null @@ -1,157 +0,0 @@ -/* classes: h_files */ - -#ifndef ROOTH -#define ROOTH - -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - -#include "libguile/__scm.h" -#include "libguile/debug.h" - - - -#define scm_flo0 scm_sys_protects[0] -#define scm_listofnull scm_sys_protects[1] -#define scm_undefineds scm_sys_protects[2] -#define scm_nullvect scm_sys_protects[3] -#define scm_nullstr scm_sys_protects[4] -#define scm_symhash scm_sys_protects[5] -#define scm_weak_symhash scm_sys_protects[6] -#define scm_symhash_vars scm_sys_protects[7] -#define scm_kw_obarray scm_sys_protects[8] -#define scm_type_obj_list scm_sys_protects[9] -#define scm_first_type scm_sys_protects[10] -#define scm_stand_in_procs scm_sys_protects[11] -#define scm_object_whash scm_sys_protects[12] -#define scm_permobjs scm_sys_protects[13] -#define scm_asyncs scm_sys_protects[14] -#ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[15] -#define SCM_NUM_PROTECTS 16 -#else -#define SCM_NUM_PROTECTS 15 -#endif - -extern SCM scm_sys_protects[]; - - - -extern long scm_tc16_root; - -#define SCM_ROOTP(obj) (scm_tc16_root == SCM_TYP16 (obj)) -#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CDR (root)) - -typedef struct scm_root_state -{ - SCM_STACKITEM * stack_base; - jmp_buf save_regs_gc_mark; - int errjmp_bad; - - SCM rootcont; - SCM dynwinds; - SCM continuation_stack; - SCM continuation_stack_ptr; -#ifdef DEBUG_EXTENSIONS - /* It is very inefficient to have this variable in the root state. */ - scm_debug_frame *last_debug_frame; -#endif - - SCM progargs; /* vestigial */ - SCM exitval; /* vestigial */ - - SCM cur_inp; - SCM cur_outp; - SCM cur_errp; - SCM def_inp; - SCM def_outp; - SCM def_errp; - - SCM system_transformer; - SCM top_level_lookup_closure_var; - - SCM handle; /* The root object for this root state */ - SCM parent; /* The parent root object */ -} scm_root_state; - -#define scm_stack_base (scm_root->stack_base) -#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark) -#define scm_errjmp_bad (scm_root->errjmp_bad) - -#define scm_rootcont (scm_root->rootcont) -#define scm_dynwinds (scm_root->dynwinds) -#define scm_continuation_stack (scm_root->continuation_stack) -#define scm_continuation_stack_ptr (scm_root->continuation_stack_ptr) -#define scm_progargs (scm_root->progargs) -#ifdef USE_THREADS -#define scm_last_debug_frame (scm_root->last_debug_frame) -#endif -#define scm_exitval (scm_root->exitval) -#define scm_cur_inp (scm_root->cur_inp) -#define scm_cur_outp (scm_root->cur_outp) -#define scm_cur_errp (scm_root->cur_errp) -#define scm_def_inp (scm_root->def_inp) -#define scm_def_outp (scm_root->def_outp) -#define scm_def_errp (scm_root->def_errp) -#define scm_top_level_lookup_closure_var \ - (scm_root->top_level_lookup_closure_var) -#define scm_system_transformer (scm_root->system_transformer) - -#ifdef USE_THREADS -#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA) -#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root) -#else /* USE_THREADS */ -extern struct scm_root_state *scm_root; -#define scm_set_root(new_root) (scm_root = (new_root)) -#endif /* USE_THREADS */ - - - -extern SCM scm_make_root SCM_P ((SCM parent)); -extern SCM scm_call_with_dynamic_root SCM_P ((SCM thunk, SCM handler)); -extern SCM scm_apply_with_dynamic_root SCM_P ((SCM proc, SCM a1, SCM args, SCM handler)); -extern SCM scm_call_catching_errors SCM_P ((SCM (*thunk)(), SCM (*err_filter)(), void * closure)); -extern void scm_init_root SCM_P ((void)); - -#endif /* ROOTH */ diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in deleted file mode 100644 index 4578d3ace..000000000 --- a/libguile/scmconfig.h.in +++ /dev/null @@ -1,287 +0,0 @@ -/* scmconfig.h.in. Generated automatically from configure.in by autoheader. */ - -/* Define if on AIX 3. - System headers sometimes define this. - We just want to avoid a redefinition error message. */ -#ifndef _ALL_SOURCE -#undef _ALL_SOURCE -#endif - -/* Define to empty if the keyword does not work. */ -#undef const - -/* Define to the type of elements in the array set by `getgroups'. - Usually this is either `int' or `gid_t'. */ -#undef GETGROUPS_T - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef gid_t - -/* Define if your struct stat has st_blksize. */ -#undef HAVE_ST_BLKSIZE - -/* Define if your struct stat has st_blocks. */ -#undef HAVE_ST_BLOCKS - -/* Define if your struct stat has st_rdev. */ -#undef HAVE_ST_RDEV - -/* Define if you have <sys/wait.h> that is POSIX.1 compatible. */ -#undef HAVE_SYS_WAIT_H - -/* Define if on MINIX. */ -#undef _MINIX - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef mode_t - -/* Define if the system does not provide POSIX.1 features except - with this defined. */ -#undef _POSIX_1_SOURCE - -/* Define if you need to in order for stat and other things to work. */ -#undef _POSIX_SOURCE - -/* Define as the return type of signal handlers (int or void). */ -#undef RETSIGTYPE - -/* Define if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Define if you can safely include both <sys/time.h> and <time.h>. */ -#undef TIME_WITH_SYS_TIME - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef uid_t - -/* Define these two if you want support for debugging of Scheme - programs. */ -#undef DEBUG_EXTENSIONS -#undef READER_EXTENSIONS - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Set this to the name of a field in FILE which contains the number - of buffered characters waiting to be read. */ -#undef FILE_CNT_FIELD - -/* Define this if your stdio has _gptr and _egptr fields which can - be compared to give the number of buffered characters waiting to - be read. */ -#undef FILE_CNT_GPTR - -/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields - which can be compared to give the number of buffered characters - waiting to be read. */ -#undef FILE_CNT_READPTR - -/* Define this if your system defines struct linger, for use with the - getsockopt and setsockopt system calls. */ -#undef HAVE_STRUCT_LINGER - -/* Define this if floats are the same size as longs. */ -#undef SCM_SINGLES - -/* Define this if a callee's stack frame has a higher address than the - caller's stack frame. On most machines, this is not the case. */ -#undef SCM_STACK_GROWS_UP - -/* Define this if <utime.h> doesn't define struct utimbuf unless - _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */ -#undef UTIMBUF_NEEDS_POSIX - -/* Define this if we should #include <libc.h> when we've already - #included <unistd.h>. On some systems, they conflict, and libc.h - should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in - aclocal.m4. */ -#undef LIBC_H_WITH_UNISTD_H - -/* Define these to indicate the current version of Guile. These - values are supposed to be supplied by the configuration system. */ -#undef GUILE_MAJOR_VERSION -#undef GUILE_MINOR_VERSION -#undef GUILE_VERSION - -/* Define if using cooperative multithreading. */ -#undef USE_COOP_THREADS - -/* Define if using "FSU" pthreads. */ -#undef USE_FSU_PTHREADS - -/* Define if using MIT pthreads. */ -#undef USE_MIT_PTHREADS - -/* Define if using PCthreads pthreads. */ -#undef USE_PCTHREADS_PTHREADS - -/* Define if using any sort of threads. */ -#undef USE_THREADS - -/* Name of this package. */ -#undef PACKAGE - -/* Define if you want support for dynamic linking. */ -#undef DYNAMIC_LINKING - -/* Define if you have the ctermid function. */ -#undef HAVE_CTERMID - -/* Define if you have the ftime function. */ -#undef HAVE_FTIME - -/* Define if you have the getcwd function. */ -#undef HAVE_GETCWD - -/* Define if you have the geteuid function. */ -#undef HAVE_GETEUID - -/* Define if you have the inet_aton function. */ -#undef HAVE_INET_ATON - -/* Define if you have the lstat function. */ -#undef HAVE_LSTAT - -/* Define if you have the mkdir function. */ -#undef HAVE_MKDIR - -/* Define if you have the mknod function. */ -#undef HAVE_MKNOD - -/* Define if you have the nice function. */ -#undef HAVE_NICE - -/* Define if you have the putenv function. */ -#undef HAVE_PUTENV - -/* Define if you have the readlink function. */ -#undef HAVE_READLINK - -/* Define if you have the rename function. */ -#undef HAVE_RENAME - -/* Define if you have the rmdir function. */ -#undef HAVE_RMDIR - -/* Define if you have the select function. */ -#undef HAVE_SELECT - -/* Define if you have the setegid function. */ -#undef HAVE_SETEGID - -/* Define if you have the seteuid function. */ -#undef HAVE_SETEUID - -/* Define if you have the setlocale function. */ -#undef HAVE_SETLOCALE - -/* Define if you have the setpgid function. */ -#undef HAVE_SETPGID - -/* Define if you have the setsid function. */ -#undef HAVE_SETSID - -/* Define if you have the shl_load function. */ -#undef HAVE_SHL_LOAD - -/* Define if you have the strerror function. */ -#undef HAVE_STRERROR - -/* Define if you have the strftime function. */ -#undef HAVE_STRFTIME - -/* Define if you have the strptime function. */ -#undef HAVE_STRPTIME - -/* Define if you have the symlink function. */ -#undef HAVE_SYMLINK - -/* Define if you have the sync function. */ -#undef HAVE_SYNC - -/* Define if you have the tcgetpgrp function. */ -#undef HAVE_TCGETPGRP - -/* Define if you have the tcsetpgrp function. */ -#undef HAVE_TCSETPGRP - -/* Define if you have the times function. */ -#undef HAVE_TIMES - -/* Define if you have the uname function. */ -#undef HAVE_UNAME - -/* Define if you have the waitpid function. */ -#undef HAVE_WAITPID - -/* Define if you have the <dirent.h> header file. */ -#undef HAVE_DIRENT_H - -/* Define if you have the <libc.h> header file. */ -#undef HAVE_LIBC_H - -/* Define if you have the <limits.h> header file. */ -#undef HAVE_LIMITS_H - -/* Define if you have the <malloc.h> header file. */ -#undef HAVE_MALLOC_H - -/* Define if you have the <memory.h> header file. */ -#undef HAVE_MEMORY_H - -/* Define if you have the <ndir.h> header file. */ -#undef HAVE_NDIR_H - -/* Define if you have the <string.h> header file. */ -#undef HAVE_STRING_H - -/* Define if you have the <sys/dir.h> header file. */ -#undef HAVE_SYS_DIR_H - -/* Define if you have the <sys/ioctl.h> header file. */ -#undef HAVE_SYS_IOCTL_H - -/* Define if you have the <sys/ndir.h> header file. */ -#undef HAVE_SYS_NDIR_H - -/* Define if you have the <sys/select.h> header file. */ -#undef HAVE_SYS_SELECT_H - -/* Define if you have the <sys/time.h> header file. */ -#undef HAVE_SYS_TIME_H - -/* Define if you have the <sys/timeb.h> header file. */ -#undef HAVE_SYS_TIMEB_H - -/* Define if you have the <sys/times.h> header file. */ -#undef HAVE_SYS_TIMES_H - -/* Define if you have the <sys/types.h> header file. */ -#undef HAVE_SYS_TYPES_H - -/* Define if you have the <sys/utime.h> header file. */ -#undef HAVE_SYS_UTIME_H - -/* Define if you have the <time.h> header file. */ -#undef HAVE_TIME_H - -/* Define if you have the <unistd.h> header file. */ -#undef HAVE_UNISTD_H - -/* Define if you have the <utime.h> header file. */ -#undef HAVE_UTIME_H - -/* Define if you have the dl library (-ldl). */ -#undef HAVE_LIBDL - -/* Define if you have the dld library (-ldld). */ -#undef HAVE_LIBDLD diff --git a/libguile/scmhob.h b/libguile/scmhob.h deleted file mode 100644 index 6bd61489a..000000000 --- a/libguile/scmhob.h +++ /dev/null @@ -1,205 +0,0 @@ -/* This was modified to try out compiling with Guile. */ - - -/* scmhob.h is a header file for scheme source compiled with hobbit4d - Copyright (C) 1992, 1993, 1994, 1995 Tanel Tammet - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 1, or (at your option) -any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*/ - - -#include <stdio.h> -#include <ctype.h> -#include "libguile/_scm.h" - - - -#define abrt scm_abort -#define absval scm_abs -#define angle scm_angle -#define append scm_append -#define assoc scm_assoc -#define assq scm_assq -#define assv scm_assv -#define big2dbl scm_big2dbl -#define close_port scm_close_port -#define cons scm_cons -#define cur_input_port scm_current_input_port -#define cur_output_port scm_current_output_port -#define difference scm_difference -#define display scm_display -#define divide scm_divide -#define eof_objectp scm_eof_object_p -#define eqp scm_eq_p -#define equal scm_equal_p -#define eqv scm_eqv_p -#define evenp scm_even_p -#define exactp scm_exact_p -#define greaterp scm_gr_p -#define greqp scm_geq_p -#define imag_part scm_imag_part -#define in2ex scm_inexact_to_exact -#define inexactp scm_inexact_p -#define input_portp scm_input_port_p -#define intp scm_integer_p -#define length scm_length -#define leqp scm_leq_p -#define lessp scm_less_p -#define lgcd scm_gcd -#define list_ref scm_list_ref -#define list_tail scm_list_tail -#define listp scm_list_p -#define llcm scm_lcm -#define lmax scm_max -#define lmin scm_min -#define lquotient scm_quotient -#define lread(X) scm_read((X), SCM_UNDEFINED) -#define lremainder scm_remainder -#define lwrite scm_write -#define magnitude scm_magnitude -#define makcclo scm_makcclo -#define makdbl scm_makdbl -#define make_string scm_make_string -#define make_vector scm_make_vector -#define makpolar scm_make_polar -#define makrect scm_make_rectangular -#define member scm_member -#define memq scm_memq -#define memv scm_memv -#define modulo scm_modulo -#define my_time scm_get_internal_run_time -#define negativep scm_negative_p -#define newline scm_newline -#define number2string scm_number_to_string -#define oddp scm_odd_p -#define open_file scm_open_file -#define output_portp scm_output_port_p -#define peek_char scm_peek_char -#define positivep scm_positive_p -#define procedurep scm_procedure_p -#define product scm_product -#define quit scm_quit -#define read_char scm_read_char -#define real_part scm_real_part -#define realp scm_real_p -#define reverse scm_reverse -#define set_inp scm_set_current_input_port -#define set_outp scm_set_current_output_port -#define st_append scm_string_append -#define st_equal scm_string_equal_p -#define st_leqp scm_string_leq_p -#define st_lessp scm_string_less_p -#define st_set scm_string_set_x -#define stci_equal scm_string_ci_equal_p -#define stci_leqp scm_string_ci_leq_p -#define stci_lessp scm_string_ci_less_p -#define string scm_string -#define string2list scm_string_to_list -#define string2number scm_string_to_number -#define string2symbol scm_string_to_symbol -#define string_copy scm_string_copy -#define string_fill scm_string_fill_x -#define substring scm_substring -#define sum scm_sum -#define symbol2string scm_symbol_to_string -#define vector scm_vector -#define vector2list scm_vector_to_list -#define vector_ref scm_vector_ref -#define vector_set scm_vector_set_x -#define write_char scm_write_char -#define zerop scm_zero_p - - - -#define STBL_VECTOR_SET(v,k,o) (v[((long)SCM_INUM(k))] = o) -#define STBL_VECTOR_REF(v,k) (v[((long)SCM_INUM(k))]) -#define CHAR_LESSP(x,y) ((SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_LEQP(x,y) ((SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_EQ(x,y) ((upcase[SCM_ICHR(x)]==upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_LESSP(x,y) ((upcase[SCM_ICHR(x)] < upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_LEQP(x,y) ((upcase[SCM_ICHR(x)] <= upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_ALPHAP(chr) ((isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define SCM_CHAR_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_WHITEP(chr) ((isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_UPPERP(chr) ((isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_LOWERP(chr) ((isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR2INT(chr) SCM_MAKINUM(SCM_ICHR(chr)) -#define INT2CHAR(n) SCM_MAKICHR(SCM_INUM(n)) -#define CHAR_UPCASE(chr) SCM_MAKICHR(upcase[SCM_ICHR(chr)]) -#define CHAR_DOWNCASE(chr) SCM_MAKICHR(downcase[SCM_ICHR(chr)]) -#define ST_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str)) -#define ST_REF(str,k) SCM_MAKICHR(SCM_CHARS(str)[SCM_INUM(k)]) -#define VECTOR_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v)) - -#ifdef SCM_FLOATS -#include <math.h> -#endif -#ifdef SCM_BIGDIG -#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (SCM_REALP(x) ? (double) SCM_REALPART(x) : (double) big2dbl(x))) -#else -#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (double) SCM_REALPART(x)) -#endif - -#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0)) -#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0)) -#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0)) -#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0)) -#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0)) -#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0)) -#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0)) -#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0)) -#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0)) -#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0)) -#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0)) -#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0)) -#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0)) -#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0)) -#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0)) -#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0)) -#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0)) -#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0)) -#define SCM_FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0)) -#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0)) -#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0)) -#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0)) - -/* the following defs come from the #ifdef HOBBIT part of scm.h */ - -#define SBOOL(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F) - -#define BOOLEAN_P(x) ((x)==SCM_BOOL_T || (x)==SCM_BOOL_F) -#define CHAR_P SCM_ICHRP -#define SYMBOL_P(x) (SCM_ISYMP(x) || (!(SCM_IMP(x)) && SCM_SYMBOLP(x))) -#define VECTOR_P(x) (!(SCM_IMP(x)) && SCM_VECTORP(x)) -#define PAIR_P(x) (!(SCM_IMP(x)) && SCM_CONSP(x)) -#define NUMBER_P SCM_INUMP -#define INTEGER_P SCM_INUMP -#define STRING_P(x) (!(SCM_IMP(x)) && SCM_STRINGP(x)) -#define NULL_P SCM_NULLP -#define ZERO_P(x) ((x)==SCM_INUM0) -#define POSITIVE_P(x) ((x) > SCM_INUM0) -#define NEGATIVE_P(x) ((x) < SCM_INUM0) - -#define NOT(x) ((x)==SCM_BOOL_F ? SCM_BOOL_T : SCM_BOOL_F) -#define SET_CAR(x,y) (CAR(x) = (SCM)(y)) -#define SET_CDR(x,y) (CDR(x) = (SCM)(y)) -#define VECTOR_SET(v,k,o) (SCM_VELTS(v)[((long)SCM_INUM(k))] = o) -#define VECTOR_REF(v,k) (SCM_VELTS(v)[((long)SCM_INUM(k))]) -#define CL_VECTOR_SET(v,k,o) (SCM_VELTS(v)[k] = o) -#define CL_VECTOR_REF(v,k) (SCM_VELTS(v)[k]) -#define GLOBAL(x) (*(x)) - -#define append2(lst1,lst2) (append(scm_cons2(lst1,lst2,SCM_EOL))) -#define procedure_pred_(x) (SCM_BOOL_T==procedurep(x)) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c deleted file mode 100644 index 7429a1598..000000000 --- a/libguile/scmsigs.c +++ /dev/null @@ -1,368 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <signal.h> -#include "_scm.h" - -#include "scmsigs.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - - -#if (__TURBOC__==1) -#define signal ssignal /* Needed for TURBOC V1.0 */ -#endif - -#ifdef USE_MIT_PTHREADS -#undef signal -#define signal pthread_signal -#endif - - - -/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/ - -#ifdef RETSIGTYPE -#define SIGRETTYPE RETSIGTYPE -#else -#ifdef STDC_HEADERS -#if (__TURBOC__==1) -#define SIGRETTYPE int -#else -#define SIGRETTYPE void -#endif -#else -#ifdef linux -#define SIGRETTYPE void -#else -#define SIGRETTYPE int -#endif -#endif -#endif - -#ifdef vms -#ifdef __GNUC__ -#define SIGRETTYPE int -#endif -#endif - - - -#define SIGFN(NAME, SCM_NAME, SIGNAL) \ -static SIGRETTYPE \ -NAME (sig) \ - int sig; \ -{ \ - signal (SIGNAL, NAME); \ - scm_take_signal (SCM_NAME); \ -} - -#ifdef SIGHUP -SIGFN(scm_hup_signal, SCM_HUP_SIGNAL, SIGHUP) -#endif - -#ifdef SIGINT -SIGFN(scm_int_signal, SCM_INT_SIGNAL, SIGINT) -#endif - -#ifdef SIGFPE -SIGFN(scm_fpe_signal, SCM_FPE_SIGNAL, SIGFPE) -#endif - -#ifdef SIGBUS -SIGFN(scm_bus_signal, SCM_BUS_SIGNAL, SIGBUS) -#endif - -#ifdef SIGSEGV -SIGFN(scm_segv_signal, SCM_SEGV_SIGNAL, SIGSEGV) -#endif - -#ifdef SIGALRM -SIGFN(scm_alrm_signal, SCM_ALRM_SIGNAL, SIGALRM) -#endif - -#define FAKESIGFN(NAME, SCM_NAME) \ -static SIGRETTYPE \ -NAME (sig) \ - int sig; \ -{ \ - scm_take_signal (SCM_NAME); \ -} - -#if 0 -/* !!! */ -FAKESIGFN(scm_gc_signal, SCM_GC_SIGNAL) -FAKESIGFN(scm_tick_signal, SCM_TICK_SIGNAL) -#endif - - -SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm); - -SCM -scm_alarm (i) - SCM i; -{ - unsigned int j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm); - SCM_SYSCALL (j = alarm (SCM_INUM (i))); - return SCM_MAKINUM (j); -} - - -SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause); - -SCM -scm_pause () -{ - pause (); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep); - -SCM -scm_sleep (i) - SCM i; -{ - unsigned int j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep); -#ifdef __HIGHC__ - SCM_SYSCALL(j = 0; sleep(SCM_INUM(i));); -#else - SCM_SYSCALL(j = sleep(SCM_INUM(i));); -#endif - return SCM_MAKINUM (j); -} - -SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise); - -SCM -scm_raise(sig) - SCM sig; -{ - SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise); -# ifdef vms - return SCM_MAKINUM(gsignal((int)SCM_INUM(sig))); -# else - return kill (getpid(), (int)SCM_INUM(sig)) ? SCM_BOOL_F : SCM_BOOL_T; -# endif -} - - -#ifdef SIGHUP -static SIGRETTYPE (*oldhup) (); -#endif - -#ifdef SIGINT -static SIGRETTYPE (*oldint) (); -#endif - -#ifdef SIGFPE -static SIGRETTYPE (*oldfpe) (); -#endif - -#ifdef SIGBUS -static SIGRETTYPE (*oldbus) (); -#endif - -#ifdef SIGSEGV /* AMIGA lacks! */ -static SIGRETTYPE (*oldsegv) (); -#endif - -#ifdef SIGALRM -static SIGRETTYPE (*oldalrm) (); -#endif - -#ifdef SIGPIPE -static SIGRETTYPE (*oldpipe) (); -#endif - - - -void -scm_init_signals () -{ -#ifdef SIGINT - oldint = signal (SIGINT, scm_int_signal); -#endif -#ifdef SIGHUP - oldhup = signal (SIGHUP, scm_hup_signal); -#endif -#ifdef SIGFPE - oldfpe = signal (SIGFPE, scm_fpe_signal); -#endif -#ifdef SIGBUS - oldbus = signal (SIGBUS, scm_bus_signal); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - oldsegv = signal (SIGSEGV, scm_segv_signal); -#endif -#ifdef SIGALRM - alarm (0); /* kill any pending ALRM interrupts */ - oldalrm = signal (SIGALRM, scm_alrm_signal); -#endif -#ifdef SIGPIPE - oldpipe = signal (SIGPIPE, SIG_IGN); -#endif -#ifdef ultrix - siginterrupt (SIGINT, 1); - siginterrupt (SIGALRM, 1); - siginterrupt (SIGHUP, 1); - siginterrupt (SIGPIPE, 1); -#endif /* ultrix */ -} - -/* This is used in preparation for a possible fork(). Ignore all - signals before the fork so that child will catch only if it - establishes a handler */ - -void -scm_ignore_signals () -{ -#ifdef ultrix - siginterrupt (SIGINT, 0); - siginterrupt (SIGALRM, 0); - siginterrupt (SIGHUP, 0); - siginterrupt (SIGPIPE, 0); -#endif /* ultrix */ - signal (SIGINT, SIG_IGN); -#ifdef SIGHUP - signal (SIGHUP, SIG_DFL); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, SIG_DFL); -#endif -#ifdef SIGBUS - signal (SIGBUS, SIG_DFL); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, SIG_DFL); -#endif - /* Some documentation claims that ALRMs are cleared accross forks. - If this is not always true then the value returned by alarm(0) - will have to be saved and scm_unignore_signals() will have to - reinstate it. */ - /* This code should be neccessary only if the forked process calls - alarm() without establishing a handler: - #ifdef SIGALRM - oldalrm = signal(SIGALRM, SIG_DFL); - #endif */ - /* These flushes are per warning in man page on fork(). */ - fflush (stdout); - fflush (stderr); -} - - -void -scm_unignore_signals () -{ - signal (SIGINT, scm_int_signal); -#ifdef SIGHUP - signal (SIGHUP, scm_hup_signal); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, scm_fpe_signal); -#endif -#ifdef SIGBUS - signal (SIGBUS, scm_bus_signal); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, scm_segv_signal); -#endif -#ifdef SIGALRM - signal (SIGALRM, scm_alrm_signal); -#endif -#ifdef ultrix - siginterrupt (SIGINT, 1); - siginterrupt (SIGALRM, 1); - siginterrupt (SIGHUP, 1); - siginterrupt (SIGPIPE, 1); -#endif /* ultrix */ -} - -SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals); - -SCM -scm_restore_signals () -{ -#ifdef ultrix - siginterrupt (SIGINT, 0); - siginterrupt (SIGALRM, 0); - siginterrupt (SIGHUP, 0); - siginterrupt (SIGPIPE, 0); -#endif /* ultrix */ - signal (SIGINT, oldint); -#ifdef SIGHUP - signal (SIGHUP, oldhup); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, oldfpe); -#endif -#ifdef SIGBUS - signal (SIGBUS, oldbus); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, oldsegv); -#endif -#ifdef SIGPIPE - signal (SIGPIPE, oldpipe); -#endif -#ifdef SIGALRM - alarm (0); /* kill any pending ALRM interrupts */ - signal (SIGALRM, oldalrm); -#endif - return SCM_UNSPECIFIED; -} - - - -void -scm_init_scmsigs () -{ -#include "scmsigs.x" -} - diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h deleted file mode 100644 index 3b8bdc48c..000000000 --- a/libguile/scmsigs.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef SCMSIGSH -#define SCMSIGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_alarm SCM_P ((SCM i)); -extern SCM scm_pause SCM_P ((void)); -extern SCM scm_sleep SCM_P ((SCM i)); -extern SCM scm_raise SCM_P ((SCM sig)); -extern void scm_init_signals SCM_P ((void)); -extern void scm_ignore_signals SCM_P ((void)); -extern void scm_unignore_signals SCM_P ((void)); -extern SCM scm_restore_signals SCM_P ((void)); -extern void scm_init_scmsigs SCM_P ((void)); - -#endif /* SCMSIGSH */ diff --git a/libguile/sequences.c b/libguile/sequences.c deleted file mode 100644 index 38c59e082..000000000 --- a/libguile/sequences.c +++ /dev/null @@ -1,113 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "sequences.h" - - - - - -int -scm_obj_length (obj) - SCM obj; -{ - int i; - i = scm_ilength(obj); - if (i >= 0) - return i; - else if (SCM_NIMP (obj)) - { - if (SCM_ROSTRINGP (obj)) - return SCM_ROLENGTH (obj); - else if (SCM_VECTORP (obj)) - return SCM_LENGTH (obj); - else - return -1; - } - else - return -1; -} - - -SCM_PROC(s_length, "length", 1, 0, 0, scm_length); - -SCM -scm_length(x) - SCM x; -{ - int i; - i = scm_obj_length(x); - if (i >= 0) - return SCM_MAKINUM (i); - else - { - SCM_ASSERT(0, x, SCM_ARG1, s_length); - return SCM_BOOL_F; - } -} - - - - - -SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse); - -SCM -scm_reverse (objs) - SCM objs; -{ - return scm_list_reverse (objs); -} - - - - - -void -scm_init_sequences () -{ -#include "sequences.x" -} - diff --git a/libguile/sequences.h b/libguile/sequences.h deleted file mode 100644 index 6520457fc..000000000 --- a/libguile/sequences.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef SEQUENCESH -#define SEQUENCESH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - - - - - -extern int scm_obj_length SCM_P ((SCM obj)); -extern SCM scm_length SCM_P ((SCM x)); -extern SCM scm_reverse SCM_P ((SCM objs)); -extern void scm_init_sequences SCM_P ((void)); - -#endif /* SEQUENCESH */ diff --git a/libguile/simpos.c b/libguile/simpos.c deleted file mode 100644 index ee0f7a94d..000000000 --- a/libguile/simpos.c +++ /dev/null @@ -1,152 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "scmsigs.h" -#include "simpos.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -extern int system(); - - -#ifndef _Windows -SCM_PROC(s_system, "system", 1, 0, 0, scm_system); - -SCM -scm_system(cmd) - SCM cmd; -{ - SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system); - if (SCM_ROSTRINGP (cmd)) - cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0); - scm_ignore_signals(); -# ifdef AZTEC_C - cmd = SCM_MAKINUM(Execute(SCM_ROCHARS(cmd), 0, 0)); -# else - cmd = SCM_MAKINUM(0L+system(SCM_ROCHARS(cmd))); -# endif - scm_unignore_signals(); - return cmd; -} -#endif - -extern char *getenv(); -SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv); - -SCM -scm_getenv(nam) - SCM nam; -{ - char *val; - SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv); - if (SCM_ROSTRINGP (nam)) - nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); - val = getenv(SCM_CHARS(nam)); - return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; -} - -#ifdef vms -# define SYSTNAME "VMS" -#endif -#ifdef unix -# define SYSTNAME "UNIX" -#endif -#ifdef MWC -# define SYSTNAME "COHERENT" -#endif -#ifdef _Windows -# define SYSTNAME "WINDOWS" -#else -# ifdef MSDOS -# define SYSTNAME "MS-DOS" -# endif -#endif -#ifdef __EMX__ -# define SYSTNAME "OS/2" -#endif -#ifdef __IBMC__ -# define SYSTNAME "OS/2" -#endif -#ifdef THINK_C -# define SYSTNAME "THINKC" -#endif -#ifdef AMIGA -# define SYSTNAME "AMIGA" -#endif -#ifdef atarist -# define SYSTNAME "ATARIST" -#endif -#ifdef mach -# define SYSTNAME "MACH" -#endif -#ifdef ARM_ULIB -# define SYSTNAME "ACORN" -#endif - -SCM_PROC(s_software_type, "software-type", 0, 0, 0, scm_software_type); - -SCM -scm_software_type() -{ -#ifdef nosve - return SCM_CAR(scm_intern("nosve", 5)); -#else - return SCM_CAR(scm_intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); -#endif -} - - -void -scm_init_simpos () -{ -#include "simpos.x" -} - diff --git a/libguile/simpos.h b/libguile/simpos.h deleted file mode 100644 index 023966ad1..000000000 --- a/libguile/simpos.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef SIMPOSH -#define SIMPOSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_system SCM_P ((SCM cmd)); -extern SCM scm_getenv SCM_P ((SCM nam)); -extern SCM scm_software_type SCM_P ((void)); -extern void scm_init_simpos SCM_P ((void)); - -#endif /* SIMPOSH */ diff --git a/libguile/smob.c b/libguile/smob.c deleted file mode 100644 index 90c27f6fe..000000000 --- a/libguile/smob.c +++ /dev/null @@ -1,129 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "smob.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - - - -/* scm_smobs scm_numsmob - * implement a dynamicly resized array of smob records. - * Indexes into this table are used when generating type - * tags for smobjects (if you know a tag you can get an index and conversely). - */ -scm_sizet scm_numsmob; -scm_smobfuns *scm_smobs; - - -long -scm_newsmob (smob) - scm_smobfuns *smob; -{ - char *tmp; - if (255 <= scm_numsmob) - goto smoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, (1 + scm_numsmob) * sizeof (scm_smobfuns))); - if (tmp) - { - scm_smobs = (scm_smobfuns *) tmp; - scm_smobs[scm_numsmob].mark = smob->mark; - scm_smobs[scm_numsmob].free = smob->free; - scm_smobs[scm_numsmob].print = smob->print; - scm_smobs[scm_numsmob].equalp = smob->equalp; - scm_numsmob++; - } - SCM_ALLOW_INTS; - if (!tmp) - smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob), (char *) SCM_NALLOC, "newsmob"); - return scm_tc7_smob + (scm_numsmob - 1) * 256; -} - -/* {Initialization for i/o types, float, bignum, the type of free cells} - */ - -static scm_smobfuns freecell = -{ - scm_mark0, - scm_free0, - 0, - 0 -}; - -static scm_smobfuns flob = -{ - scm_mark0, - /*flofree*/ 0, - scm_floprint, - scm_floequal -}; - -static scm_smobfuns bigob = -{ - scm_mark0, - /*bigfree*/ 0, - scm_bigprint, - scm_bigequal -}; - - - - -void -scm_smob_prehistory () -{ - scm_numsmob = 0; - scm_smobs = (scm_smobfuns *) malloc (7 * sizeof (scm_smobfuns)); - - /* WARNING: These scm_newsmob calls must be done in this order */ - scm_newsmob (&freecell); - scm_newsmob (&flob); - scm_newsmob (&bigob); - scm_newsmob (&bigob); /* n.b.: two smobs, one smobfuns */ -} - diff --git a/libguile/smob.h b/libguile/smob.h deleted file mode 100644 index cf5712fc7..000000000 --- a/libguile/smob.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef SMOBH -#define SMOBH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -typedef struct scm_smobfuns -{ - SCM (*mark) SCM_P ((SCM)); - scm_sizet (*free) SCM_P ((SCM)); - int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - SCM (*equalp) SCM_P ((SCM, SCM)); -} scm_smobfuns; - - - -#define SCM_SMOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); -#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); - -extern scm_sizet scm_numsmob; -extern scm_smobfuns *scm_smobs; - - - -/* Everyone who uses smobs needs to print. */ -#include "libguile/ports.h" -#include "libguile/genio.h" - -/* ... and they all need to GC. */ -#include "libguile/markers.h" - - -extern long scm_newsmob SCM_P ((scm_smobfuns *smob)); -extern void scm_smob_prehistory SCM_P ((void)); - -#endif /* SMOBH */ diff --git a/libguile/snarf.h b/libguile/snarf.h deleted file mode 100644 index 2104531aa..000000000 --- a/libguile/snarf.h +++ /dev/null @@ -1,94 +0,0 @@ -/* classes: h_files */ - -/* Macros for snarfing initialization actions from C source. */ - -#ifndef LIBGUILE_SNARF_H -#define LIBGUILE_SNARF_H - -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ - static char RANAME[]=STR -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ - static char RANAME[]=STR -#else -#ifdef __cplusplus -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*) (...)) CFN) -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ -%%% scm_make_subr(RANAME, TYPE, (SCM (*)(...)) CFN) -#else /* not __cplusplus */ -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN) -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ -%%% scm_make_subr(RANAME, TYPE, CFN) -#endif /* not __cplusplus */ -#endif - -#ifndef SCM_MAGIC_SNARFER -#define SCM_SYMBOL(c_name, scheme_name) \ - static SCM c_name = SCM_BOOL_F -#else -#define SCM_SYMBOL(C_NAME, SCHEME_NAME) \ -%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME))) -#endif - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_GLOBAL(c_name, scheme_name) \ - static SCM c_name = SCM_BOOL_F -#else -#define SCM_GLOBAL(C_NAME, SCHEME_NAME) \ -%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F) -#endif - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \ - static SCM C_NAME = SCM_BOOL_F -#else -#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \ -%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, scm_long2num (VALUE)) -#endif - -#endif /* LIBGUILE_SNARF_H */ diff --git a/libguile/socket.c b/libguile/socket.c deleted file mode 100644 index d28cd104e..000000000 --- a/libguile/socket.c +++ /dev/null @@ -1,398 +0,0 @@ -/* "socket.c" internet socket support for client/server in SCM - * Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* Written in 1994 by Aubrey Jaffer. - * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion. - * Rewritten by Gary Houston to be a closer interface to the C socket library. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "feature.h" - -#include "socket.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <sys/types.h> -#include <sys/socket.h> -#include <sys/un.h> -#include <netinet/in.h> -#include <netdb.h> -#include <arpa/inet.h> - - - -#ifndef STDC_HEADERS -int close (); -#endif /* STDC_HEADERS */ - -extern int inet_aton (); - -SCM_PROC (s_sys_inet_aton, "inet-aton", 1, 0, 0, scm_sys_inet_aton); - -SCM -scm_sys_inet_aton (address) - SCM address; -{ - struct in_addr soka; - - SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton); - if (SCM_SUBSTRP (address)) - address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); - if (inet_aton (SCM_ROCHARS (address), &soka) == 0) - scm_syserror (s_sys_inet_aton); - return scm_ulong2num (ntohl (soka.s_addr)); -} - - -SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa); - -SCM -scm_inet_ntoa (inetid) - SCM inetid; -{ - struct in_addr addr; - char *s; - SCM answer; - addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa)); - SCM_DEFER_INTS; - s = inet_ntoa (addr); - answer = scm_makfromstr (s, strlen (s), 0); - SCM_ALLOW_INTS; - return answer; -} - -SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof); - -SCM -scm_inet_netof (address) - SCM address; -{ - struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof)); - return scm_ulong2num ((unsigned long) inet_netof (addr)); -} - -SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof); - -SCM -scm_lnaof (address) - SCM address; -{ - struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof)); - return scm_ulong2num ((unsigned long) inet_lnaof (addr)); -} - - -SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr); - -SCM -scm_inet_makeaddr (net, lna) - SCM net; - SCM lna; -{ - struct in_addr addr; - unsigned long netnum; - unsigned long lnanum; - - netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr); - lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr); - addr = inet_makeaddr (netnum, lnanum); - return scm_ulong2num (ntohl (addr.s_addr)); -} - - -/* !!! Doesn't take address format. - * Assumes hostent stream isn't reused. - */ - -SCM_PROC (s_sys_gethost, "gethost", 0, 1, 0, scm_sys_gethost); - -SCM -scm_sys_gethost (name) - SCM name; -{ - SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - SCM lst = SCM_EOL; - struct hostent *entry; - struct in_addr inad; - char **argv; - int i = 0; -#ifdef HAVE_GETHOSTENT - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = gethostent (); - } - else -#endif - if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = gethostbyname (SCM_CHARS (name)); - } - else - { - inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost)); - SCM_DEFER_INTS; - entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_gethost); - ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0); - ve[1] = scm_makfromstrs (-1, entry->h_aliases); - ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L); - ve[3] = SCM_MAKINUM (entry->h_length + 0L); - if (sizeof (struct in_addr) != entry->h_length) - { - ve[4] = SCM_BOOL_F; - return ans; - } - for (argv = entry->h_addr_list; argv[i]; i++); - while (i--) - { - inad = *(struct in_addr *) argv[i]; - lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst); - } - ve[4] = lst; - return ans; -} - - -SCM_PROC (s_sys_getnet, "getnet", 0, 1, 0, scm_sys_getnet); - -SCM -scm_sys_getnet (name) - SCM name; -{ - SCM ans; - SCM *ve; - struct netent *entry; - - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getnetent (); - } - else if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getnetbyname (SCM_CHARS (name)); - } - else - { - unsigned long netnum; - netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet); - SCM_DEFER_INTS; - entry = getnetbyaddr (netnum, AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_getnet); - ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); - ve[1] = scm_makfromstrs (-1, entry->n_aliases); - ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); - ve[3] = scm_ulong2num (entry->n_net + 0L); - return ans; -} - -SCM_PROC (s_sys_getproto, "getproto", 0, 1, 0, scm_sys_getproto); - -SCM -scm_sys_getproto (name) - SCM name; -{ - SCM ans; - SCM *ve; - struct protoent *entry; - - ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getprotoent (); - } - else if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getprotobyname (SCM_CHARS (name)); - } - else - { - unsigned long protonum; - protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto); - SCM_DEFER_INTS; - entry = getprotobynumber (protonum); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_getproto); - ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); - ve[1] = scm_makfromstrs (-1, entry->p_aliases); - ve[2] = SCM_MAKINUM (entry->p_proto + 0L); - return ans; -} - - -static SCM scm_return_entry SCM_P ((struct servent *entry)); - -static SCM -scm_return_entry (entry) - struct servent *entry; -{ - SCM ans; - SCM *ve; - - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0); - ve[1] = scm_makfromstrs (-1, entry->s_aliases); - ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); - ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0); - SCM_ALLOW_INTS; - return ans; -} - -SCM_PROC (s_sys_getserv, "getserv", 0, 2, 0, scm_sys_getserv); - -SCM -scm_sys_getserv (name, proto) - SCM name; - SCM proto; -{ - struct servent *entry; - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getservent (); - if (!entry) - scm_syserror (s_sys_getserv); - return scm_return_entry (entry); - } - SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv); - if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto)); - } - else - { - SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv); - SCM_DEFER_INTS; - entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto)); - } - if (!entry) - scm_syserror (s_sys_getserv); - return scm_return_entry (entry); -} - -SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost); - -SCM -scm_sethost (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endhostent (); - else - sethostent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet); - -SCM -scm_setnet (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endnetent (); - else - setnetent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto); - -SCM -scm_setproto (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endprotoent (); - else - setprotoent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv); - -SCM -scm_setserv (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endservent (); - else - setservent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - - -void -scm_init_socket () -{ - scm_add_feature ("socket"); -#include "socket.x" -} - - diff --git a/libguile/socket.h b/libguile/socket.h deleted file mode 100644 index b87afb18f..000000000 --- a/libguile/socket.h +++ /dev/null @@ -1,69 +0,0 @@ -/* classes: h_files */ - -#ifndef SOCKETH -#define SOCKETH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_sys_gethost SCM_P ((SCM name)); -extern SCM scm_sys_inet_aton SCM_P ((SCM address)); -extern SCM scm_inet_ntoa SCM_P ((SCM inetid)); -extern SCM scm_inet_netof SCM_P ((SCM address)); -extern SCM scm_lnaof SCM_P ((SCM address)); -extern SCM scm_inet_makeaddr SCM_P ((SCM net, SCM lna)); -extern SCM scm_sys_getnet SCM_P ((SCM name)); -extern SCM scm_sys_getproto SCM_P ((SCM name)); -extern SCM scm_sys_getserv SCM_P ((SCM name, SCM proto)); -extern SCM scm_sethost SCM_P ((SCM arg)); -extern SCM scm_setnet SCM_P ((SCM arg)); -extern SCM scm_setproto SCM_P ((SCM arg)); -extern SCM scm_setserv SCM_P ((SCM arg)); -extern void scm_init_socket SCM_P ((void)); - -#endif /* SOCKETH */ diff --git a/libguile/srcprop.c b/libguile/srcprop.c deleted file mode 100644 index 86705826f..000000000 --- a/libguile/srcprop.c +++ /dev/null @@ -1,363 +0,0 @@ -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include <stdio.h> -#include "_scm.h" -#include "smob.h" -#include "alist.h" -#include "debug.h" -#include "hashtab.h" -#include "hash.h" -#include "weaks.h" - -#include "srcprop.h" - -/* {Source Properties} - * - * Properties of source list expressions. - * Five of these have special meaning and optimized storage: - * - * filename string The name of the source file. - * copy list A copy of the list expression. - * line integer The source code line number. - * column integer The source code column number. - * breakpoint boolean Sets a breakpoint on this form. - * - * Most properties above can be set by the reader. - * - */ - -SCM scm_i_filename; -SCM scm_i_copy; -SCM scm_i_line; -SCM scm_i_column; -SCM scm_i_breakpoint; - -long scm_tc16_srcprops; -static scm_srcprops_chunk *srcprops_chunklist = 0; -static scm_srcprops *srcprops_freelist = 0; - - -static SCM marksrcprops SCM_P ((SCM obj)); - -static SCM -marksrcprops (obj) - SCM obj; -{ - SCM_SETGC8MARK (obj); - scm_gc_mark (SRCPROPFNAME (obj)); - scm_gc_mark (SRCPROPCOPY (obj)); - return SRCPROPPLIST (obj); -} - - -static scm_sizet freesrcprops SCM_P ((SCM obj)); - -static scm_sizet -freesrcprops (obj) - SCM obj; -{ - *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist; - srcprops_freelist = (scm_srcprops *) SCM_CDR (obj); - return 0; /* srcprops_chunks are not freed until leaving guile */ -} - - -static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); - -static int -prinsrcprops (obj, port, pstate) - SCM obj; - SCM port; - scm_print_state *pstate; -{ - int writingp = SCM_WRITINGP (pstate); - scm_gen_puts (scm_regular_string, "#<srcprops ", port); - SCM_SET_WRITINGP (pstate, 1); - scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); - SCM_SET_WRITINGP (pstate, writingp); - scm_gen_putc ('>', port); - return 1; -} - -static scm_smobfuns srcpropssmob = -{marksrcprops, freesrcprops, prinsrcprops, 0}; - - -SCM -scm_make_srcprops (line, col, filename, copy, plist) - int line; - int col; - SCM filename; - SCM copy; - SCM plist; -{ - register SCM ans; - register scm_srcprops *ptr; - SCM_DEFER_INTS; - if ((ptr = srcprops_freelist) != NULL) - srcprops_freelist = *(scm_srcprops **)ptr; - else - { - int i; - scm_srcprops_chunk *mem; - scm_sizet n = sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); - SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops"); - scm_mallocated += n; - mem->next = srcprops_chunklist; - srcprops_chunklist = mem; - ptr = &mem->srcprops[0]; - for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) - *(scm_srcprops **)&ptr[i] = &ptr[i + 1]; - *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; - srcprops_freelist = (scm_srcprops *) &ptr[1]; - } - SCM_NEWCELL (ans); - SCM_SETCAR (ans, scm_tc16_srcprops); - ptr->pos = SRCPROPMAKPOS (line, col); - ptr->fname = filename; - ptr->copy = copy; - ptr->plist = plist; - SCM_SETCDR (ans, (SCM) ptr); - SCM_ALLOW_INTS; - return ans; -} - - -SCM -scm_srcprops_to_plist (obj) - SCM obj; -{ - SCM plist = SRCPROPPLIST (obj); - if (!SCM_UNBNDP (SRCPROPCOPY (obj))) - plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist); - if (!SCM_UNBNDP (SRCPROPFNAME (obj))) - plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist); - plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); - plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); - plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist); - return plist; -} - -SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties); - -SCM -scm_source_properties (obj) - SCM obj; -{ - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_source_properties, 1, obj); -#endif - p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL); - if (p != (SCM) NULL && SRCPROPSP (p)) - return scm_srcprops_to_plist (p); - return SCM_EOL; -} - -/* Perhaps this procedure should look through an alist - and try to make a srcprops-object...? */ -SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x); - -SCM -scm_set_source_properties_x (obj, plist) - SCM obj; - SCM plist; -{ - SCM handle; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_properties_x, 1, obj); -#endif - handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); - SCM_SETCDR (handle, plist); - return plist; -} - -SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property); - -SCM -scm_source_property (obj, key) - SCM obj; - SCM key; -{ - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_source_property, 1, obj); -#endif - p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); - if (SCM_IMP (p) || !SRCPROPSP (p)) - goto plist; - if (scm_i_breakpoint == key) p = SRCPROPBRK (p); - else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p)); - else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p)); - else if (scm_i_filename == key) p = SRCPROPFNAME (p); - else if (scm_i_copy == key) p = SRCPROPCOPY (p); - else - { - p = SRCPROPPLIST (p); - plist: - p = scm_assoc (key, p); - return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); - } - return SCM_UNBNDP (p) ? SCM_BOOL_F : p; -} - -SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x); - -SCM -scm_set_source_property_x (obj, key, datum) - SCM obj; - SCM key; - SCM datum; -{ - scm_whash_handle h; - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_property_x, 1, obj); -#endif - h = scm_whash_get_handle (scm_source_whash, obj); - if (SCM_WHASHFOUNDP (h)) - p = SCM_WHASHREF (scm_source_whash, h); - else - { - h = scm_whash_create_handle (scm_source_whash, obj); - p = SCM_EOL; - } - if (scm_i_breakpoint == key) - if (SCM_FALSEP (datum)) - CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, 0, SCM_UNDEFINED, - SCM_UNDEFINED, p))); - else - SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, 0, SCM_UNDEFINED, - SCM_UNDEFINED, p))); - else if (scm_i_line == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SETSRCPROPLINE (p, datum); - else - SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p)); - } - else if (scm_i_column == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SETSRCPROPCOL (p, datum); - else - SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p)); - } - else if (scm_i_filename == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SRCPROPFNAME (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); - } - else if (scm_i_filename == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SRCPROPCOPY (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); - } - else - SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); - return SCM_UNSPECIFIED; -} - - -void -scm_init_srcprop () -{ - scm_tc16_srcprops = scm_newsmob (&srcpropssmob); - scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); - - scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED)); - scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED)); - scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED)); - scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED)); - scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); - - scm_sysintern ("source-whash", scm_source_whash); -#include "srcprop.x" -} - -void -scm_finish_srcprop () -{ - register scm_srcprops_chunk *ptr = srcprops_chunklist, *next; - while (ptr) - { - next = ptr->next; - free ((char *) ptr); - scm_mallocated -= sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - ptr = next; - } -} diff --git a/libguile/srcprop.h b/libguile/srcprop.h deleted file mode 100644 index ae9358b0c..000000000 --- a/libguile/srcprop.h +++ /dev/null @@ -1,134 +0,0 @@ -/* classes: h_files */ - -#ifndef SRCPROPH -#define SRCPROPH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -/* {The old whash table interface} - * *fixme* This is a temporary solution until weak hash table access - * has been optimized for speed (which is quite necessary, if they are - * used for recording of source code positions...) - */ - -#define scm_whash_handle SCM - -#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0) -#define SCM_WHASHFOUNDP(h) ((h) != SCM_BOOL_F) -#define SCM_WHASHREF(whash, handle) SCM_CDR (handle) -#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj) -#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0) -#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0) -#define scm_whash_insert(whash, key, obj) \ -{ \ - register SCM w = (whash); \ - SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \ -} \ - - -/* {Source properties} - */ - -extern long scm_tc16_srcprops; - -typedef struct scm_srcprops -{ - unsigned long pos; - SCM fname; - SCM copy; - SCM plist; -} scm_srcprops; - -#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */ -typedef struct scm_srcprops_chunk -{ - struct scm_srcprops_chunk *next; - scm_srcprops srcprops[1]; -} scm_srcprops_chunk; - -#define SRCPROPSP(p) (SCM_TYP16 (p) == scm_tc16_srcprops) -#define SRCPROPBRK(p) ((1L << 16) & SCM_CAR (p) ? SCM_BOOL_T : SCM_BOOL_F) -#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos -#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) -#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CDR (p))->fname -#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CDR (p))->copy -#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CDR (p))->plist -#define SETSRCPROPBRK(p) (SCM_SETOR_CAR (p, (1L << 16))) -#define CLEARSRCPROPBRK(p) SCM_SETAND_CAR (p, ~(1L << 16)) -#define SRCPROPMAKPOS(l,c) (((l) << 12) + (c)) -#define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c)) -#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) -#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) - -#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\ - && SRCPROPSP (t.arg1)\ - && (1L << 16) & SCM_CAR (t.arg1)) - -#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_i_trace)) - -extern SCM scm_i_filename; -extern SCM scm_i_copy; -extern SCM scm_i_line; -extern SCM scm_i_column; -extern SCM scm_i_breakpoint; - - - - -extern SCM scm_srcprops_to_plist SCM_P ((SCM obj)); -extern SCM scm_make_srcprops SCM_P ((int line, int col, SCM fname, SCM copy, SCM plist)); -extern SCM scm_source_property SCM_P ((SCM obj, SCM key)); -extern SCM scm_set_source_property_x SCM_P ((SCM obj, SCM key, SCM datum)); -extern SCM scm_source_properties SCM_P ((SCM obj)); -extern SCM scm_set_source_properties_x SCM_P ((SCM obj, SCM props)); -extern void scm_finish_srcprop SCM_P ((void)); -extern void scm_init_srcprop SCM_P ((void)); - -#endif /* SRCPROPH */ diff --git a/libguile/stackchk.c b/libguile/stackchk.c deleted file mode 100644 index 92846170f..000000000 --- a/libguile/stackchk.c +++ /dev/null @@ -1,104 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" - -#include "stackchk.h" - - -/* {Stack Checking} - */ - -#ifdef STACK_CHECKING -int scm_stack_checking_enabled_p; - -SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow"); - -void -scm_report_stack_overflow () -{ - scm_stack_checking_enabled_p = 0; - scm_error (scm_stack_overflow_key, - NULL, - "Stack overflow", - SCM_BOOL_F, - SCM_BOOL_F); -} - -#endif - -long -scm_stack_size (start) - SCM_STACKITEM *start; -{ - SCM_STACKITEM stack; -#ifdef SCM_STACK_GROWS_UP - return &stack - start; -#else - return start - &stack; -#endif /* def SCM_STACK_GROWS_UP */ -} - - -void -scm_stack_report () -{ - SCM_STACKITEM stack; - scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM), - 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, " of stack: 0x", scm_cur_errp); - scm_intprint ((long) SCM_BASE (scm_rootcont), 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, " - 0x", scm_cur_errp); - scm_intprint ((long) &stack, 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, "\n", scm_cur_errp); -} - - - - -void -scm_init_stackchk () -{ -#include "stackchk.x" -} diff --git a/libguile/stackchk.h b/libguile/stackchk.h deleted file mode 100644 index 6e6a358fc..000000000 --- a/libguile/stackchk.h +++ /dev/null @@ -1,92 +0,0 @@ -/* classes: h_files */ - -#ifndef STACKCHKH -#define STACKCHKH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - -#include "libguile/continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "libguile/debug.h" -#endif - - -/* With debug extensions we have the possibility to use the debug options - * to disable stack checking. - */ -#ifdef DEBUG_EXTENSIONS -#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT -#else -/* *fixme* This option should be settable also without debug extensions. */ -#define SCM_STACK_LIMIT 100000 -#define SCM_STACK_CHECKING_P 1 -#endif - -#ifdef STACK_CHECKING -# ifdef SCM_STACK_GROWS_UP -# define SCM_STACK_OVERFLOW_P(s)\ - (s - SCM_BASE (scm_rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) -# else -# define SCM_STACK_OVERFLOW_P(s)\ - (SCM_BASE (scm_rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) -# endif -# define SCM_CHECK_STACK\ - {\ - SCM_STACKITEM stack;\ - if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\ - scm_report_stack_overflow ();\ - } -#else -# define SCM_CHECK_STACK /**/ -#endif /* STACK_CHECKING */ - -extern int scm_stack_checking_enabled_p; - - - -extern void scm_report_stack_overflow SCM_P ((void)); -extern long scm_stack_size SCM_P ((SCM_STACKITEM *start)); -extern void scm_stack_report SCM_P ((void)); -extern void scm_init_stackchk SCM_P ((void)); - -#endif /* STACKCHKH */ diff --git a/libguile/stacks.h b/libguile/stacks.h deleted file mode 100644 index 3cbcb28be..000000000 --- a/libguile/stacks.h +++ /dev/null @@ -1,135 +0,0 @@ -/* classes: h_files */ - -#ifndef STACKSH -#define STACKSH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - -/* {Frames and stacks} - */ - -typedef struct scm_info_frame { - SCM flags; - SCM source; - SCM proc; - SCM args; -} scm_info_frame; -#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame) / sizeof (SCM)) - -#define SCM_STACK(obj) ((scm_stack *) SCM_STRUCT_DATA (obj)) -#define SCM_STACK_LAYOUT "pwuourpW" -typedef struct scm_stack { - SCM id; /* Stack id */ - scm_info_frame *frames; /* Info frames */ - unsigned int length; /* Stack length */ - unsigned int tail_length; - scm_info_frame tail[1]; -} scm_stack; - -extern SCM scm_stack_type; - -#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE (obj) == scm_stack_type) -#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) - -#define SCM_FRAMEP(obj) (SCM_CONSP (obj) \ - && SCM_NIMP (SCM_CAR (obj)) \ - && SCM_STACKP (SCM_CAR (obj)) \ - && SCM_INUMP (SCM_CDR (obj))) \ - - -#define SCM_FRAME_REF(frame, slot) \ -(SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \ - -#define SCM_FRAME_NUMBER(frame) \ -(SCM_BACKWARDS_P \ - ? SCM_INUM (SCM_CDR (frame)) \ - : (SCM_STACK_LENGTH (SCM_CAR (frame)) \ - - SCM_INUM (SCM_CDR (frame)) \ - - 1)) \ - -#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags) -#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source) -#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc) -#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args) -#define SCM_FRAME_PREV(frame) scm_frame_previous (frame) -#define SCM_FRAME_NEXT(frame) scm_frame_next (frame) - -#define SCM_FRAMEF_VOID (1L << 2) -#define SCM_FRAMEF_REAL (1L << 3) -#define SCM_FRAMEF_PROC (1L << 4) -#define SCM_FRAMEF_EVAL_ARGS (1L << 5) -#define SCM_FRAMEF_OVERFLOW (1L << 6) - -#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID) -#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL) -#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC) -#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS) -#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW) - - - -SCM scm_stack_p SCM_P ((SCM obj)); -SCM scm_make_stack SCM_P ((SCM args)); -SCM scm_stack_ref SCM_P ((SCM stack, SCM i)); -SCM scm_stack_length SCM_P ((SCM stack)); - -SCM scm_frame_p SCM_P ((SCM obj)); -SCM scm_last_stack_frame SCM_P ((SCM obj)); -SCM scm_frame_number SCM_P ((SCM frame)); -SCM scm_frame_source SCM_P ((SCM frame)); -SCM scm_frame_procedure SCM_P ((SCM frame)); -SCM scm_frame_arguments SCM_P ((SCM frame)); -SCM scm_frame_previous SCM_P ((SCM frame)); -SCM scm_frame_next SCM_P ((SCM frame)); -SCM scm_frame_real_p SCM_P ((SCM frame)); -SCM scm_frame_procedure_p SCM_P ((SCM frame)); -SCM scm_frame_evaluating_args_p SCM_P ((SCM frame)); -SCM scm_frame_overflow_p SCM_P ((SCM frame)); - -void scm_init_stacks SCM_P ((void)); - -#endif /* STACKSH */ diff --git a/libguile/stamp-h.in b/libguile/stamp-h.in deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/stamp-h.in +++ /dev/null diff --git a/libguile/stime.c b/libguile/stime.c deleted file mode 100644 index efc9d172f..000000000 --- a/libguile/stime.c +++ /dev/null @@ -1,206 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "stime.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -# ifdef HAVE_SYS_TYPES_H -# include <sys/types.h> -# endif - -# ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -# else -# ifdef HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# ifdef HAVE_TIME_H -# include <time.h> -# endif -# endif -# endif - -# ifdef HAVE_SYS_TIMES_H -# include <sys/times.h> -# else -# ifdef HAVE_SYS_TIMEB_H -# include <sys/timeb.h> -# endif -# endif - -#ifdef CLK_TCK -# define CLKTCK CLK_TCK -# ifdef CLOCKS_PER_SEC -# ifdef unix -# ifndef ARM_ULIB -# include <sys/times.h> -# endif -# define LACK_CLOCK - /* This is because clock() might be POSIX rather than ANSI. - This occurs on HP-UX machines */ -# endif -# endif -#else -# ifdef CLOCKS_PER_SEC -# define CLKTCK CLOCKS_PER_SEC -# else -# define LACK_CLOCK -# define CLKTCK 60 -# endif -#endif - - -# ifdef HAVE_FTIME -# include <sys/timeb.h> -# endif - - -#ifdef __STDC__ -# define timet time_t -#else -# define timet long -#endif - -#ifdef HAVE_TIMES -static -long mytime() -{ - struct tms time_buffer; - times(&time_buffer); - return time_buffer.tms_utime + time_buffer.tms_stime; -} -#else -# ifdef LACK_CLOCK -# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) -# else -# define mytime clock -# endif -#endif - - - -#ifdef HAVE_FTIME - -extern int ftime (struct timeb *); - -struct timeb scm_your_base = {0}; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - struct timeb time_buffer; - long tmp; - ftime(&time_buffer); - time_buffer.time -= scm_your_base.time; - tmp = time_buffer.millitm - scm_your_base.millitm; - tmp = time_buffer.time*1000L + tmp; - tmp *= CLKTCK; - tmp /= 1000; - return SCM_MAKINUM(tmp); -} - -#else - -timet scm_your_base = 0; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - return SCM_MAKINUM((time((timet*)0) - scm_your_base) * (int)CLKTCK); -} -#endif - - - -static long scm_my_base = 0; - -SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); -SCM -scm_get_internal_run_time() -{ - return SCM_MAKINUM(mytime()-scm_my_base); -} - -SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); -SCM -scm_current_time() -{ - timet timv = time((timet*)0); - SCM ans; - ans = scm_ulong2num(timv); - return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans; -} - -long -scm_time_in_msec(x) - long x; -{ - if (CLKTCK==60) return (x*50)/3; - else - return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK); -} - -void -scm_init_stime() -{ - scm_sysintern("internal-time-units-per-second", - SCM_MAKINUM((long)CLKTCK)); - -#ifdef HAVE_FTIME - if (!scm_your_base.time) ftime(&scm_your_base); -#else - if (!scm_your_base) time(&scm_your_base); -#endif - - if (!scm_my_base) scm_my_base = mytime(); - -#include "stime.x" -} - diff --git a/libguile/stime.h b/libguile/stime.h deleted file mode 100644 index 54a093bc3..000000000 --- a/libguile/stime.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef TIMEH -#define TIMEH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern SCM scm_get_internal_real_time SCM_P ((void)); -extern SCM scm_get_internal_run_time SCM_P ((void)); -extern SCM scm_current_time SCM_P ((void)); -extern long scm_time_in_msec SCM_P ((long x)); -extern void scm_init_stime SCM_P ((void)); - -#endif /* TIMEH */ diff --git a/libguile/strerror.c b/libguile/strerror.c deleted file mode 100644 index 4723d04e8..000000000 --- a/libguile/strerror.c +++ /dev/null @@ -1,32 +0,0 @@ -/* Turning errno values into English error messages. - Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -char * -strerror (errnum) - int errnum; -{ - extern char *sys_errlist[]; - extern int sys_nerr; - - if (errnum >= 0 && errnum < sys_nerr) - return sys_errlist[errnum]; - return (char *) "Unknown error"; -} diff --git a/libguile/strings.c b/libguile/strings.c deleted file mode 100644 index e3c24406b..000000000 --- a/libguile/strings.c +++ /dev/null @@ -1,407 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strings.h" - - -/* {Strings} - */ - -SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p); - -SCM -scm_string_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p); - -SCM -scm_read_only_string_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string); -SCM_PROC(s_string, "string", 0, 0, 1, scm_string); - -SCM -scm_string (chrs) - SCM chrs; -{ - SCM res; - register unsigned char *data; - long i; - long len; - SCM_DEFER_INTS; - i = scm_ilength (chrs); - if (i < 0) - { - SCM_ALLOW_INTS; - SCM_ASSERT (0, chrs, SCM_ARG1, s_string); - } - len = 0; - { - SCM s; - - for (len = 0, s = chrs; s != SCM_EOL; s = SCM_CDR (s)) - if (SCM_ICHRP (SCM_CAR (s))) - len += 1; - else if (SCM_NIMP (SCM_CAR (s)) && SCM_ROSTRINGP (SCM_CAR (s))) - len += SCM_ROLENGTH (SCM_CAR (s)); - else - { - SCM_ALLOW_INTS; - SCM_ASSERT (0, s, SCM_ARG1, s_string); - } - } - res = scm_makstr (len, 0); - data = SCM_UCHARS (res); - for (;SCM_NNULLP (chrs);chrs = SCM_CDR (chrs)) - { - if (SCM_ICHRP (SCM_CAR (chrs))) - *data++ = SCM_ICHR (SCM_CAR (chrs)); - else - { - int l; - char * c; - l = SCM_ROLENGTH (SCM_CAR (chrs)); - c = SCM_ROUCHARS (SCM_CAR (chrs)); - while (l) - { - --l; - *data++ = *c++; - } - } - } - SCM_ALLOW_INTS; - return res; -} - - -SCM -scm_makstr (len, slots) - long len; - int slots; -{ - SCM s; - SCM * mem; - SCM_NEWCELL (s); - --slots; - SCM_REDEFER_INTS; - mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1, - s_string); - if (slots >= 0) - { - int x; - mem[slots] = (SCM)mem; - for (x = 0; x < slots; ++x) - mem[x] = SCM_BOOL_F; - } - SCM_SETCHARS (s, (char *) (mem + slots + 1)); - SCM_SETLENGTH (s, len, scm_tc7_string); - SCM_REALLOW_INTS; - SCM_CHARS (s)[len] = 0; - return s; -} - -/* converts C scm_array of strings to SCM scm_list of strings. */ -/* If argc < 0, a null terminated scm_array is assumed. */ - -SCM -scm_makfromstrs (argc, argv) - int argc; - char **argv; -{ - int i = argc; - SCM lst = SCM_EOL; - if (0 > i) - for (i = 0; argv[i]; i++); - while (i--) - lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst); - return lst; -} - - - -SCM -scm_take0str (it) - char * it; -{ - SCM answer; - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - SCM_SETLENGTH (answer, strlen (it), scm_tc7_string); - SCM_SETCHARS (answer, it); - SCM_ALLOW_INTS; - return answer; -} - - -SCM -scm_makfromstr (src, len, slots) - const char *src; - scm_sizet len; - int slots; -{ - SCM s; - register char *dst; - s = scm_makstr ((long) len, slots); - dst = SCM_CHARS (s); - while (len--) - *dst++ = *src++; - return s; -} - - - -SCM -scm_makfrom0str (src) - const char *src; -{ - if (!src) return SCM_BOOL_F; - return scm_makfromstr (src, (scm_sizet) strlen (src), 0); -} - - -SCM -scm_makfrom0str_opt (src) - const char *src; -{ - return scm_makfrom0str (src); -} - - - - -SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string); - -SCM -scm_make_string (k, chr) - SCM k; - SCM chr; -{ - SCM res; - register unsigned char *dst; - register long i; - SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string); - i = SCM_INUM (k); - res = scm_makstr (i, 0); - dst = SCM_UCHARS (res); - if SCM_ICHRP (chr) - { - char c = SCM_ICHR (chr); - for (i--;i >= 0;i--) - { - dst[i] = c; - } - } - return res; -} - -SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length); - -SCM -scm_string_length (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length); - return SCM_MAKINUM (SCM_ROLENGTH (str)); -} - -SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref); - -SCM -scm_string_ref (str, k) - SCM str; - SCM k; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref); - if (k == SCM_UNDEFINED) - k = SCM_MAKINUM (0); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref); - SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref); - return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]); -} - -SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x); - -SCM -scm_string_set_x (str, k, chr) - SCM str; - SCM k; - SCM chr; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_set_x); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x); - SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_set_x); - SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring); - -SCM -scm_substring (str, start, end) - SCM str; - SCM start; - SCM end; -{ - long l; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), - str, SCM_ARG1, s_substring); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring); - if (end == SCM_UNDEFINED) - end = SCM_MAKINUM (SCM_ROLENGTH (str)); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring); - SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring); - SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring); - l = SCM_INUM (end)-SCM_INUM (start); - SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring); - return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0); -} - -SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append); - -SCM -scm_string_append (args) - SCM args; -{ - SCM res; - register long i = 0; - register SCM l, s; - register unsigned char *data; - for (l = args;SCM_NIMP (l);) { - SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append); - s = SCM_CAR (l); - SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s), - s, SCM_ARGn, s_string_append); - i += SCM_ROLENGTH (s); - l = SCM_CDR (l); - } - SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append); - res = scm_makstr (i, 0); - data = SCM_UCHARS (res); - for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { - s = SCM_CAR (l); - for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i]; - } - return res; -} - -SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring); - -SCM -scm_make_shared_substring (str, frm, to) - SCM str; - SCM frm; - SCM to; -{ - long f; - long t; - SCM answer; - SCM len_str; - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring); - - if (frm == SCM_UNDEFINED) - frm = SCM_MAKINUM (0); - else - SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring); - - if (to == SCM_UNDEFINED) - to = SCM_MAKINUM (SCM_ROLENGTH (str)); - else - SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring); - - f = SCM_INUM (frm); - t = SCM_INUM (to); - SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring); - SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE, s_make_shared_substring); - - SCM_NEWCELL (answer); - SCM_NEWCELL (len_str); - - SCM_DEFER_INTS; - if (SCM_SUBSTRP (str)) - { - long offset; - offset = SCM_INUM (SCM_SUBSTR_OFFSET (str)); - f += offset; - t += offset; - SCM_SETCAR (len_str, SCM_MAKINUM (f)); - SCM_SETCDR (len_str, SCM_SUBSTR_STR (str)); - SCM_SETCDR (answer, len_str); - SCM_SETLENGTH (answer, t - f, scm_tc7_substring); - } - else - { - SCM_SETCAR (len_str, SCM_MAKINUM (f)); - SCM_SETCDR (len_str, str); - SCM_SETCDR (answer, len_str); - SCM_SETLENGTH (answer, t - f, scm_tc7_substring); - } - SCM_ALLOW_INTS; - return answer; -} - - -void -scm_init_strings () -{ -#include "strings.x" -} - diff --git a/libguile/strings.h b/libguile/strings.h deleted file mode 100644 index 93f5a6e43..000000000 --- a/libguile/strings.h +++ /dev/null @@ -1,79 +0,0 @@ -/* classes: h_files */ - -#ifndef STRINGSH -#define STRINGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -#define SCM_STRINGP(x) (SCM_TYP7S(x)==scm_tc7_string) -#define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) - - - - -extern SCM scm_string_p SCM_P ((SCM x)); -extern SCM scm_read_only_string_p SCM_P ((SCM x)); -extern SCM scm_string SCM_P ((SCM chrs)); -extern SCM scm_makstr SCM_P ((long len, int slots)); -extern SCM scm_makfromstrs SCM_P ((int argc, char **argv)); -extern SCM scm_take0str SCM_P ((char * it)); -extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots)); -extern SCM scm_makfrom0str SCM_P ((const char *src)); -extern SCM scm_makfrom0str_opt SCM_P ((const char *src)); -extern SCM scm_make_string SCM_P ((SCM k, SCM chr)); -extern SCM scm_string_length SCM_P ((SCM str)); -extern SCM scm_string_ref SCM_P ((SCM str, SCM k)); -extern SCM scm_string_set_x SCM_P ((SCM str, SCM k, SCM chr)); -extern SCM scm_substring SCM_P ((SCM str, SCM start, SCM end)); -extern SCM scm_string_append SCM_P ((SCM args)); -extern SCM scm_make_shared_substring SCM_P ((SCM str, SCM frm, SCM to)); -extern void scm_init_strings SCM_P ((void)); - -#endif /* STRINGSH */ diff --git a/libguile/strop.c b/libguile/strop.c deleted file mode 100644 index 2f73f9724..000000000 --- a/libguile/strop.c +++ /dev/null @@ -1,325 +0,0 @@ -/* classes: src_files */ - -/* Copyright (C) 1994 Free Software Foundation, Inc. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this software; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ - - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strop.h" - - - -int -scm_i_index (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why) - SCM * str; - SCM chr; - SCM sub_start; - SCM sub_end; - int pos; - int pos2; - int pos3; - int pos4; - char * why; -{ - unsigned char * p; - int x; - int bound; - int ch; - - SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why); - SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why); - - if (sub_start == SCM_BOOL_F) - sub_start = SCM_MAKINUM (0); - else - SCM_ASSERT ( SCM_INUMP (sub_start) - && (0 <= SCM_INUM (sub_start)) - && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)), - sub_start, pos3, why); - - if (sub_end == SCM_BOOL_F) - sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); - else - SCM_ASSERT ( SCM_INUMP (sub_end) - && (SCM_INUM (sub_start) <= SCM_INUM (sub_end)) - && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)), - sub_end, pos4, why); - - p = (unsigned char *)SCM_ROCHARS (*str) + SCM_INUM (sub_start); - bound = SCM_INUM (sub_end); - ch = SCM_ICHR (chr); - - for (x = SCM_INUM (sub_start); x < bound; ++x, ++p) - if (*p == ch) - return x; - - return -1; -} - - -int -scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why) - SCM * str; - SCM chr; - SCM sub_start; - SCM sub_end; - int pos; - int pos2; - int pos3; - int pos4; - char * why; -{ - unsigned char * p; - int x; - int upper_bound; - int lower_bound; - int ch; - - SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why); - SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why); - - if (sub_start == SCM_BOOL_F) - sub_start = SCM_MAKINUM (0); - else - SCM_ASSERT ( SCM_INUMP (sub_start) - && (0 <= SCM_INUM (sub_start)) - && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)), - sub_start, pos3, why); - - if (sub_end == SCM_BOOL_F) - sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); - else - SCM_ASSERT ( SCM_INUMP (sub_end) - && (SCM_INUM (sub_start) <= SCM_INUM (sub_end)) - && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)), - sub_end, pos4, why); - - upper_bound = SCM_INUM (sub_end); - lower_bound = SCM_INUM (sub_start); - p = upper_bound - 1 + (unsigned char *)SCM_ROCHARS (*str); - ch = SCM_ICHR (chr); - for (x = upper_bound - 1; x >= lower_bound; --x, --p) - if (*p == ch) - return x; - - return -1; -} - - -SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index); - -SCM -scm_string_index (str, chr, frm, to) - SCM str; - SCM chr; - SCM frm; - SCM to; -{ - int pos; - - if (frm == SCM_UNDEFINED) - frm = SCM_BOOL_F; - if (to == SCM_UNDEFINED) - to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index); - return (pos < 0 - ? SCM_BOOL_F - : SCM_MAKINUM (pos)); -} - -SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex); - -SCM -scm_string_rindex (str, chr, frm, to) - SCM str; - SCM chr; - SCM frm; - SCM to; -{ - int pos; - - if (frm == SCM_UNDEFINED) - frm = SCM_BOOL_F; - if (to == SCM_UNDEFINED) - to = SCM_BOOL_F; - pos = scm_i_rindex (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index); - return (pos < 0 - ? SCM_BOOL_F - : SCM_MAKINUM (pos)); -} - - - - - - -SCM_PROC(s_substring_move_left_x, "substring-move-left!", 2, 0, 1, scm_substring_move_left_x); - -SCM -scm_substring_move_left_x (str1, start1, args) - SCM str1; - SCM start1; - SCM args; -{ - SCM end1, str2, start2; - long i, j, e; - SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x), - SCM_WNA, NULL); - end1 = SCM_CAR (args); args = SCM_CDR (args); - str2 = SCM_CAR (args); args = SCM_CDR (args); - start2 = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_left_x); - SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_left_x); - i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (e-i+j <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_left_x); - while (i<e) SCM_CHARS (str2)[j++] = SCM_CHARS (str1)[i++]; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_substring_move_right_x, "substring-move-right!", 2, 0, 1, scm_substring_move_right_x); - -SCM -scm_substring_move_right_x (str1, start1, args) - SCM str1; - SCM start1; - SCM args; -{ - SCM end1, str2, start2; - long i, j, e; - SCM_ASSERT (3==scm_ilength (args), - scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL); - end1 = SCM_CAR (args); args = SCM_CDR (args); - str2 = SCM_CAR (args); args = SCM_CDR (args); - start2 = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_right_x); - SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_right_x); - i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_right_x); - while (i<e) SCM_CHARS (str2)[--j] = SCM_CHARS (str1)[--e]; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_substring_fill_x, "substring-fill!", 2, 0, 1, scm_substring_fill_x); - -SCM -scm_substring_fill_x (str, start, args) - SCM str; - SCM start; - SCM args; -{ - SCM end, fill; - long i, e; - char c; - SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x), - SCM_WNA, NULL); - end = SCM_CAR (args); args = SCM_CDR (args); - fill = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x); - SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x); - i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill); - SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start, SCM_OUTOFRANGE, s_substring_fill_x); - SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end, SCM_OUTOFRANGE, s_substring_fill_x); - while (i<e) SCM_CHARS (str)[i++] = c; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p); - -SCM -scm_string_null_p (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p); - return (SCM_ROLENGTH (str) - ? SCM_BOOL_F - : SCM_BOOL_T); -} - - -SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list); - -SCM -scm_string_to_list (str) - SCM str; -{ - long i; - SCM res = SCM_EOL; - unsigned char *src; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list); - src = SCM_ROUCHARS (str); - for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res); - return res; -} - - - -SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy); - -SCM -scm_string_copy (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_copy); - return scm_makfromstr (SCM_CHARS (str), (scm_sizet)SCM_LENGTH (str), 0); -} - - -SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x); - -SCM -scm_string_fill_x (str, chr) - SCM str; - SCM chr; -{ - register char *dst, c; - register long k; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x); - c = SCM_ICHR (chr); - dst = SCM_CHARS (str); - for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_strop () -{ -#include "strop.x" -} - diff --git a/libguile/strop.h b/libguile/strop.h deleted file mode 100644 index fea23d79c..000000000 --- a/libguile/strop.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef STROPH -#define STROPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -extern int scm_i_index SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)); -extern int scm_i_rindex SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)); -extern SCM scm_string_index SCM_P ((SCM str, SCM chr, SCM frm, SCM to)); -extern SCM scm_string_rindex SCM_P ((SCM str, SCM chr, SCM frm, SCM to)); -extern SCM scm_substring_move_left_x SCM_P ((SCM str1, SCM start1, SCM args)); -extern SCM scm_substring_move_right_x SCM_P ((SCM str1, SCM start1, SCM args)); -extern SCM scm_substring_fill_x SCM_P ((SCM str, SCM start, SCM args)); -extern SCM scm_string_null_p SCM_P ((SCM str)); -extern SCM scm_string_to_list SCM_P ((SCM str)); -extern SCM scm_string_copy SCM_P ((SCM str)); -extern SCM scm_string_fill_x SCM_P ((SCM str, SCM chr)); -extern void scm_init_strop SCM_P ((void)); - -#endif /* STROPH */ diff --git a/libguile/strorder.c b/libguile/strorder.c deleted file mode 100644 index a4fe03daa..000000000 --- a/libguile/strorder.c +++ /dev/null @@ -1,224 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strorder.h" - - -SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p); - -SCM -scm_string_equal_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p); - - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) - { - return SCM_BOOL_F; - } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (*c1++ != *c2++) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p); - -SCM -scm_string_ci_equal_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_equal_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_equal_p); - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) - { - return SCM_BOOL_F; - } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (scm_upcase(*c1++) != scm_upcase(*c2++)) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p); - -SCM -scm_string_less_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i, len, s2len; - register unsigned char *c1, *c2; - register int c; - - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_less_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_less_p); - len = SCM_ROLENGTH (s1); - s2len = i = SCM_ROLENGTH (s2); - if (len>i) i = len; - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - - for (i = 0;i<len;i++) { - c = (*c1++ - *c2++); - if (c>0) - return SCM_BOOL_F; - if (c<0) - return SCM_BOOL_T; - } - { - SCM answer; - answer = (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; - return answer; - } -} - -SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p); - -SCM -scm_string_leq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_less_p (s2, s1)); -} - -SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p); - -SCM -scm_string_gr_p (s1, s2) - SCM s1; - SCM s2; -{ - return scm_string_less_p (s2, s1); -} - -SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p); - -SCM -scm_string_geq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_less_p (s1, s2)); -} - -SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p); - -SCM -scm_string_ci_less_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i, len, s2len; - register unsigned char *c1, *c2; - register int c; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_less_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_less_p); - len = SCM_ROLENGTH (s1); - s2len = i = SCM_ROLENGTH (s2); - if (len>i) i=len; - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - for (i = 0;i<len;i++) { - c = (scm_upcase(*c1++) - scm_upcase(*c2++)); - if (c>0) return SCM_BOOL_F; - if (c<0) return SCM_BOOL_T; - } - return (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p); - -SCM -scm_string_ci_leq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1)); -} - -SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p); - -SCM -scm_string_ci_gr_p (s1, s2) - SCM s1; - SCM s2; -{ - return scm_string_ci_less_p (s2, s1); -} - -SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p); - -SCM -scm_string_ci_geq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2)); -} - - - -void -scm_init_strorder () -{ -#include "strorder.x" -} - diff --git a/libguile/strorder.h b/libguile/strorder.h deleted file mode 100644 index 2263a1c7f..000000000 --- a/libguile/strorder.h +++ /dev/null @@ -1,68 +0,0 @@ -/* classes: h_files */ - -#ifndef STRORDERH -#define STRORDERH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - - -extern SCM scm_string_equal_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_equal_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_less_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_leq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_gr_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_geq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_less_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_leq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_gr_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_geq_p SCM_P ((SCM s1, SCM s2)); -extern void scm_init_strorder SCM_P ((void)); - -#endif /* STRORDERH */ diff --git a/libguile/strports.c b/libguile/strports.c deleted file mode 100644 index 3518c9cff..000000000 --- a/libguile/strports.c +++ /dev/null @@ -1,304 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "unif.h" -#include "eval.h" -#include "read.h" - -#include "strports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -/* {Ports - string ports} - * - */ - - -static int prinstpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinstpt (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (exp, port, "string"); - return !0; -} - - -static int stputc SCM_P ((int c, SCM p)); - -static int -stputc (c, p) - int c; - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - SCM_DEFER_INTS; - if (ind >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1))); - SCM_ALLOW_INTS; - SCM_CHARS (SCM_CDR (p))[ind] = c; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return c; -} - - -static scm_sizet stwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p)); - -static scm_sizet -stwrite (str, siz, num, p) - char *str; - scm_sizet siz; - scm_sizet num; - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - scm_sizet len = siz * num; - char *dst; - SCM_DEFER_INTS; - if (ind + len >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1))); - SCM_ALLOW_INTS; - dst = &(SCM_CHARS (SCM_CDR (p))[ind]); - while (len--) - dst[len] = str[len]; - SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num)); - return num; -} - - -static int stputs SCM_P ((char *s, SCM p)); - -static int -stputs (s, p) - char *s; - SCM p; -{ - stwrite (s, 1, strlen (s), p); - return 0; -} - - -static int stgetc SCM_P ((SCM p)); - -static int -stgetc (p) - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - if (ind >= SCM_ROLENGTH (SCM_CDR (p))) - return EOF; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return SCM_ROUCHARS (SCM_CDR (p))[ind]; -} - - -SCM -scm_mkstrport (pos, str, modes, caller) - SCM pos; - SCM str; - long modes; - char * caller; -{ - SCM z; - SCM stream; - struct scm_port_table * pt; - - SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); - SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller); - stream = scm_cons(pos, str); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_strport | modes); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, stream); - SCM_ALLOW_INTS; - return z; -} - -SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string); - -SCM -scm_call_with_output_string (proc) - SCM proc; -{ - SCM p; - p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s_call_with_output_string); - scm_apply (proc, p, scm_listofnull); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))), - SCM_INUM (SCM_CAR (SCM_STREAM (p))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - -/* Return a Scheme string obtained by printing a given object. - */ - - -SCM -scm_strprint_obj (obj) - SCM obj; -{ - SCM str; - SCM port; - - str = scm_makstr (64, 0); - port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); - scm_prin1 (obj, port, 1); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))), - SCM_INUM (SCM_CAR (SCM_STREAM (port))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - - -SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string); - -SCM -scm_call_with_input_string (str, proc) - SCM str; - SCM proc; -{ - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string); - return scm_apply (proc, p, scm_listofnull); -} - - - -/* Given a null-terminated string EXPR containing a Scheme expression - read it, and return it as an SCM value. */ -SCM -scm_read_0str (expr) - char *expr; -{ - SCM port = scm_mkstrport (SCM_MAKINUM (0), - scm_makfrom0str (expr), - SCM_OPN | SCM_RDNG, - "scm_eval_0str"); - SCM form; - - /* Read expressions from that port; ignore the values. */ - form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F); - - scm_close_port (port); - return form; -} - -/* Given a null-terminated string EXPR containing Scheme program text, - evaluate it, and return the result of the last expression evaluated. */ -SCM -scm_eval_0str (expr) - char *expr; -{ - SCM port = scm_mkstrport (SCM_MAKINUM (0), - scm_makfrom0str (expr), - SCM_OPN | SCM_RDNG, - "scm_eval_0str"); - SCM form; - SCM ans = SCM_EOL; - - /* Read expressions from that port; ignore the values. */ - while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL) - ans = scm_eval_x (form); - - scm_close_port (port); - return ans; -} - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -scm_ptobfuns scm_stptob = -{ - scm_markstream, - noop0, - prinstpt, - 0, - stputc, - stputs, - stwrite, - noop0, - stgetc, - 0 -}; - - - -void -scm_init_strports () -{ -#include "strports.x" -} - diff --git a/libguile/strports.h b/libguile/strports.h deleted file mode 100644 index fc0a1ed9f..000000000 --- a/libguile/strports.h +++ /dev/null @@ -1,61 +0,0 @@ -/* classes: h_files */ - -#ifndef STRPORTSH -#define STRPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern scm_ptobfuns scm_stptob; - - - -extern SCM scm_mkstrport SCM_P ((SCM pos, SCM str, long modes, char * caller)); -extern SCM scm_call_with_output_string SCM_P ((SCM proc)); -extern SCM scm_strprint_obj SCM_P ((SCM obj)); -extern SCM scm_call_with_input_string SCM_P ((SCM str, SCM proc)); -extern SCM scm_read_0str SCM_P ((char *expr)); -extern SCM scm_eval_0str SCM_P ((char *expr)); -extern void scm_init_strports SCM_P ((void)); - -#endif /* STRPORTSH */ diff --git a/libguile/struct.c b/libguile/struct.c deleted file mode 100644 index 51f934e07..000000000 --- a/libguile/struct.c +++ /dev/null @@ -1,607 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "struct.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -static SCM required_vtable_fields = SCM_BOOL_F; -static int struct_num = 0; - - -SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout); - -SCM -scm_make_struct_layout (fields) - SCM fields; -{ - SCM new_sym; - SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields), - fields, SCM_ARG1, s_struct_make_layout); - - { - char * field_desc; - int len; - int x; - - len = SCM_ROLENGTH (fields); - field_desc = SCM_ROCHARS (fields); - SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout); - - for (x = 0; x < len; x += 2) - { - switch (field_desc[x]) - { - case 'u': - case 'p': -#if 0 - case 'i': - case 'd': -#endif - case 's': - break; - default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout); - } - - switch (field_desc[x + 1]) - { - case 'w': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), - "self fields not writable", s_struct_make_layout); - - case 'r': - case 'o': - break; - case 'R': - case 'W': - case 'O': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), - "self fields not allowed in tail array", - s_struct_make_layout); - SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]), - "tail array field must be last field in layout", - s_struct_make_layout); - break; - default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout); - } -#if 0 - if (field_desc[x] == 'd') - { - SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout); - x += 2; - goto recheck_ref; - } -#endif - } - new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F)); - } - return scm_return_first (new_sym, fields); -} - - - - - -static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits)); - -static void -init_struct (handle, tail_elts, inits) - SCM handle; - int tail_elts; - SCM inits; -{ - SCM layout; - SCM * data; - unsigned char * fields_desc; - unsigned char prot = 0; - int n_fields; - SCM * mem; - int tailp = 0; - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - fields_desc = (unsigned char *) SCM_CHARS (layout) - 2; - n_fields = SCM_LENGTH (layout) / 2; - mem = SCM_STRUCT_DATA (handle); - while (n_fields) - { - if (!tailp) - { - fields_desc += 2; - prot = fields_desc[1]; - if (SCM_LAYOUT_TAILP (prot)) - { - tailp = 1; - prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; - *mem++ = tail_elts; - n_fields += tail_elts - 1; - if (n_fields == 0) - break; - } - } - - switch (*fields_desc) - { -#if 0 - case 'i': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = 0; - else - { - *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct"); - inits = SCM_CDR (inits); - } - break; -#endif - - case 'u': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = 0; - else - { - *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct"); - inits = SCM_CDR (inits); - } - break; - - case 'p': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = SCM_EOL; - else - { - *mem = SCM_CAR (inits); - inits = SCM_CDR (inits); - } - - break; - -#if 0 - case 'd': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *((double *)mem) = 0.0; - else - { - *mem = scm_num2dbl (SCM_CAR (inits), "init_struct"); - inits = SCM_CDR (inits); - } - fields_desc += 2; - break; -#endif - - case 's': - *mem = handle; - break; - } - - n_fields--; - mem++; - } -} - - -SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p); - -SCM -scm_struct_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_STRUCTP (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p); - -SCM -scm_struct_vtable_p (x) - SCM x; -{ - SCM layout; - SCM * mem; - - if (SCM_IMP (x)) - return SCM_BOOL_F; - - if (!SCM_STRUCTP (x)) - return SCM_BOOL_F; - - layout = SCM_STRUCT_LAYOUT (x); - - if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields)) - return SCM_BOOL_F; - - if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields), - SCM_LENGTH (required_vtable_fields))) - return SCM_BOOL_F; - - mem = SCM_STRUCT_DATA (x); - - if (mem[1] != 0) - return SCM_BOOL_F; - - if (SCM_IMP (mem[0])) - return SCM_BOOL_F; - - return (SCM_SYMBOLP (mem[0]) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -/* All struct data must be allocated at an address whose bottom three - bits are zero. This is because the tag for a struct lives in the - bottom three bits of the struct's car, and the upper bits point to - the data of its vtable, which is a struct itself. Thus, if the - address of that data doesn't end in three zeros, tagging it will - destroy the pointer. - - This function allocates a block of memory, and returns a pointer at - least scm_struct_n_extra_words words into the block. Furthermore, - it guarantees that that pointer's least three significant bits are - all zero. - - The argument n_words should be the number of words that should - appear after the returned address. (That is, it shouldn't include - scm_struct_n_extra_words.) - - This function initializes the following fields of the struct: - - scm_struct_i_ptr --- the actual stort of the block of memory; the - address you should pass to 'free' to dispose of the block. - This field allows us to both guarantee that the returned - address is divisible by eight, and allow the GC to free the - block. - - scm_struct_i_n_words --- the number of words allocated to the - block, including the extra fields. This is used by the GC. - - scm_struct_i_tag --- a unique tag assigned to this struct, - allocated according to struct_num. - - Ugh. */ - - -static SCM *alloc_struct SCM_P ((int n_words, char *who)); - -static SCM * -alloc_struct (n_words, who) - int n_words; - char *who; -{ - int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7; - SCM *block = (SCM *) scm_must_malloc (size, who); - - /* Adjust the pointer to hide the extra words. */ - SCM *p = block + scm_struct_n_extra_words; - - /* Adjust it even further so it's aligned on an eight-byte boundary. */ - p = (SCM *) (((SCM) p + 7) & ~7); - - /* Initialize a few fields as described above. */ - p[scm_struct_i_ptr] = (SCM) block; - p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words); - p[scm_struct_i_tag] = struct_num++; - - return p; -} - - -SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct); - -SCM -scm_make_struct (vtable, tail_array_size, init) - SCM vtable; - SCM tail_array_size; - SCM init; -{ - SCM layout; - int basic_size; - int tail_elts; - SCM * data; - SCM handle; - - SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)), - vtable, SCM_ARG1, s_make_struct); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_struct); - - layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout]; - basic_size = SCM_LENGTH (layout) / 2; - tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - data = alloc_struct (basic_size + tail_elts, "make-struct"); - SCM_SETCDR (handle, data); - SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc); - init_struct (handle, tail_elts, init); - SCM_ALLOW_INTS; - return handle; -} - - - -SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable); - -SCM -scm_make_vtable_vtable (extra_fields, tail_array_size, init) - SCM extra_fields; - SCM tail_array_size; - SCM init; -{ - SCM fields; - SCM layout; - int basic_size; - int tail_elts; - SCM * data; - SCM handle; - - SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields), - extra_fields, SCM_ARG1, s_make_vtable_vtable); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_vtable_vtable); - - fields = scm_string_append (scm_listify (required_vtable_fields, - extra_fields, - SCM_UNDEFINED)); - layout = scm_make_struct_layout (fields); - basic_size = SCM_LENGTH (layout) / 2; - tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable"); - SCM_SETCDR (handle, data); - SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc); - SCM_STRUCT_LAYOUT (handle) = layout; - init_struct (handle, tail_elts, scm_cons (layout, init)); - SCM_ALLOW_INTS; - return handle; -} - - - - -SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref); - -SCM -scm_struct_ref (handle, pos) - SCM handle; - SCM pos; -{ - SCM answer = SCM_UNDEFINED; - SCM * data; - SCM layout; - int p; - int n_fields; - unsigned char * fields_desc; - unsigned char field_type; - - - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - p = SCM_INUM (pos); - - fields_desc = (unsigned char *)SCM_CHARS (layout); - n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words; - - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref); - - if (p * 2 < SCM_LENGTH (layout)) - { - unsigned char ref; - field_type = fields_desc[p * 2]; - ref = fields_desc[p * 2 + 1]; - if ((ref != 'r') && (ref != 'w')) - { - if ((ref == 'R') || (ref == 'W')) - field_type = 'u'; - else - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); - } - } - else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O') - field_type = fields_desc[SCM_LENGTH (layout) - 2]; - else - { - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); - abort (); - } - - switch (field_type) - { - case 'u': - answer = scm_ulong2num (data[p]); - break; - -#if 0 - case 'i': - answer = scm_long2num (data[p]); - break; - - case 'd': - answer = scm_makdbl (*((double *)&(data[p])), 0.0); - break; -#endif - - case 's': - case 'p': - answer = data[p]; - break; - - - default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref); - break; - } - - return answer; -} - - -SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x); - -SCM -scm_struct_set_x (handle, pos, val) - SCM handle; - SCM pos; - SCM val; -{ - SCM * data; - SCM layout; - int p; - int n_fields; - unsigned char * fields_desc; - unsigned char field_type; - - - - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - p = SCM_INUM (pos); - - fields_desc = (unsigned char *)SCM_CHARS (layout); - n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words; - - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x); - - if (p * 2 < SCM_LENGTH (layout)) - { - unsigned char set_x; - field_type = fields_desc[p * 2]; - set_x = fields_desc [p * 2 + 1]; - if (set_x != 'w') - SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x); - } - else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W') - field_type = fields_desc[SCM_LENGTH (layout) - 2]; - else - { - SCM_ASSERT (0, pos, "set_x denied", s_struct_ref); - abort (); - } - - switch (field_type) - { - case 'u': - data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x); - break; - -#if 0 - case 'i': - data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x); - break; - - case 'd': - *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3); - break; -#endif - - case 'p': - data[p] = val; - break; - - case 's': - SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x); - break; - - default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x); - break; - } - - return val; -} - - -SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable); - -SCM -scm_struct_vtable (handle) - SCM handle; -{ - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_vtable); - return SCM_STRUCT_VTABLE (handle); -} - - -SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag); - -SCM -scm_struct_vtable_tag (handle) - SCM handle; -{ - SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)), - handle, SCM_ARG1, s_struct_vtable_tag); - return scm_long2num (SCM_STRUCT_DATA (handle)[-1]); -} - - - - - -void -scm_init_struct () -{ - required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F)); - scm_permanent_object (required_vtable_fields); - scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset)); -#include "struct.x" -} - diff --git a/libguile/struct.h b/libguile/struct.h deleted file mode 100644 index e076a8aee..000000000 --- a/libguile/struct.h +++ /dev/null @@ -1,86 +0,0 @@ -/* classes: h_files */ - -#ifndef STRUCTH -#define STRUCTH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -/* Number of words with negative index */ -#define scm_struct_n_extra_words 3 - -/* These are how the initial words of a vtable are allocated. */ -#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */ -#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ -#define scm_struct_i_tag -1 /* A unique tag for this type.. */ -#define scm_struct_i_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_struct_i_vcell 1 /* An opaque word, managed by the garbage collector. */ -#define scm_struct_i_vtable 2 /* A pointer to the handle for this vtable. */ -#define scm_struct_i_vtable_offset 3 /* Where do user fields start? */ - - -#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc) -#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X))) -#define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1)) -#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout]) -#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable]) -/* Efficiency is important in the following macro, since it's used in GC */ -#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ - - - - -extern SCM scm_make_struct_layout SCM_P ((SCM fields)); -extern SCM scm_struct_p SCM_P ((SCM x)); -extern SCM scm_struct_vtable_p SCM_P ((SCM x)); -extern SCM scm_make_struct SCM_P ((SCM vtable, SCM tail_array_size, SCM init)); -extern SCM scm_make_vtable_vtable SCM_P ((SCM extra_fields, SCM tail_array_size, SCM init)); -extern SCM scm_struct_ref SCM_P ((SCM handle, SCM pos)); -extern SCM scm_struct_set_x SCM_P ((SCM handle, SCM pos, SCM val)); -extern SCM scm_struct_vtable SCM_P ((SCM handle)); -extern SCM scm_struct_vtable_tag SCM_P ((SCM handle)); -extern void scm_init_struct SCM_P ((void)); - -#endif /* STRUCTH */ diff --git a/libguile/symbols.c b/libguile/symbols.c deleted file mode 100644 index ec3fb9f93..000000000 --- a/libguile/symbols.c +++ /dev/null @@ -1,727 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "eval.h" -#include "variable.h" -#include "alist.h" -#include "mbstrings.h" - -#include "symbols.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - - -/* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. - */ -#define NUM_HASH_BUCKETS 137 - - - - -/* {Symbols} - */ - - -unsigned long -scm_strhash (str, len, n) - unsigned char *str; - scm_sizet len; - unsigned long n; -{ - if (len > 5) - { - scm_sizet i = 5; - unsigned long h = 264 % n; - while (i--) - h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n; - return h; - } - else - { - scm_sizet i = len; - unsigned long h = 0; - while (i) - h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n; - return h; - } -} - -int scm_symhash_dim = NUM_HASH_BUCKETS; - - -/* scm_sym2vcell - * looks up the symbol in the symhash table. - */ - -SCM -scm_sym2vcell (sym, thunk, definep) - SCM sym; - SCM thunk; - SCM definep; -{ - if (SCM_NIMP(thunk)) - { - SCM var = scm_apply (thunk, sym, scm_cons(definep, scm_listofnull)); - - if (var == SCM_BOOL_F) - return SCM_BOOL_F; - else - { - if (SCM_IMP(var) || !SCM_VARIABLEP (var)) - scm_wta (sym, "strangely interned symbol? ", ""); - return SCM_VARVCELL (var); - } - } - else - { - SCM lsym; - SCM * lsymp; - SCM z; - scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym), - (unsigned long) scm_symhash_dim); - - SCM_DEFER_INTS; - for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - SCM_ALLOW_INTS; - return z; - } - } - - for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]); - SCM_NIMP (lsym); - lsym = *(lsymp = SCM_CDRLOC (lsym))) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - if (definep) - { - /* Move handle from scm_weak_symhash to scm_symhash. */ - *lsymp = SCM_CDR (lsym); - SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]); - SCM_VELTS(scm_symhash)[scm_hash] = lsym; - } - SCM_ALLOW_INTS; - return z; - } - } - SCM_ALLOW_INTS; - return scm_wta (sym, "uninterned symbol? ", ""); - } -} - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (sym, obarray) - SCM sym; - SCM obarray; -{ - SCM lsym, z; - scm_sizet scm_hash; - - scm_hash = scm_strhash (SCM_UCHARS (sym), - (scm_sizet) SCM_LENGTH (sym), - SCM_LENGTH (obarray)); - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[scm_hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (sym, obarray) - SCM sym; - SCM obarray; -{ - SCM answer; - answer = scm_sym2ovcell_soft (sym, obarray); - if (answer != SCM_BOOL_F) - return answer; - scm_wta (sym, "uninterned symbol? ", ""); - return SCM_UNSPECIFIED; /* not reached */ -} - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). - - If OBARRAY is scm_symhash, and that doesn't contain the symbol, - check scm_weak_symhash instead. */ - - -SCM -scm_intern_obarray_soft (name, len, obarray, softness) - char *name; - scm_sizet len; - SCM obarray; - int softness; -{ - SCM lsym; - SCM z; - register scm_sizet i; - register unsigned char *tmp; - scm_sizet scm_hash; - - SCM_REDEFER_INTS; - - i = len; - tmp = (unsigned char *) name; - - if (obarray == SCM_BOOL_F) - { - scm_hash = scm_strhash (tmp, i, 1019); - goto uninterned_symbol; - } - - scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray)); - - /* softness == -1 used to mean that it was known that the symbol - wasn't already in the obarray. I don't think there are any - callers that use that case any more, but just in case... - -- JimB, Oct 1996 */ - if (softness == -1) - abort (); - - retry_new_obarray: - for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - z = SCM_CAR (z); - tmp = SCM_UCHARS (z); - if (SCM_LENGTH (z) != len) - goto trynext; - for (i = len; i--;) - if (((unsigned char *) name)[i] != tmp[i]) - goto trynext; - { - SCM a; - a = SCM_CAR (lsym); - SCM_REALLOW_INTS; - return a; - } - trynext:; - } - - if (obarray == scm_symhash) - { - obarray = scm_weak_symhash; - goto retry_new_obarray; - } - - uninterned_symbol: - if (softness) - { - SCM_REALLOW_INTS; - return SCM_BOOL_F; - } - - lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); - - SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); - SCM_SYMBOL_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F; - SCM_SYMBOL_HASH (lsym) = scm_hash; - SCM_SYMBOL_PROPS (lsym) = SCM_EOL; - if (obarray == SCM_BOOL_F) - { - SCM answer; - SCM_REALLOW_INTS; - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - SCM_SETCAR (answer, lsym); - SCM_SETCDR (answer, SCM_UNDEFINED); - SCM_REALLOW_INTS; - return answer; - } - else - { - SCM a; - SCM b; - - SCM_NEWCELL (a); - SCM_NEWCELL (b); - SCM_SETCAR (a, lsym); - SCM_SETCDR (a, SCM_UNDEFINED); - SCM_SETCAR (b, a); - SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]); - SCM_VELTS(obarray)[scm_hash] = b; - SCM_REALLOW_INTS; - return SCM_CAR (b); - } -} - - -SCM -scm_intern_obarray (name, len, obarray) - char *name; - scm_sizet len; - SCM obarray; -{ - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (name, len) - char *name; - scm_sizet len; -{ - return scm_intern_obarray (name, len, scm_symhash); -} - - -SCM -scm_intern0 (name) - char * name; -{ - return scm_intern (name, strlen (name)); -} - - -/* Intern the symbol named NAME in scm_symhash, and give it the value VAL. - NAME is null-terminated. */ -SCM -scm_sysintern (name, val) - char *name; - SCM val; -{ - SCM easy_answer; - SCM_DEFER_INTS; - easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); - if (SCM_NIMP (easy_answer)) - { - SCM_SETCDR (easy_answer, val); - SCM_ALLOW_INTS; - return easy_answer; - } - else - { - SCM lsym; - scm_sizet len = strlen (name); - register unsigned char *tmp = (unsigned char *) name; - scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim); - SCM_NEWCELL (lsym); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol); - SCM_SETCHARS (lsym, name); - lsym = scm_cons (lsym, val); - SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]); - SCM_ALLOW_INTS; - return lsym; - } -} - - -SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p); - -SCM -scm_symbol_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string); - -SCM -scm_symbol_to_string(s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string); - return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0); -} - - -SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol); - -SCM -scm_string_to_symbol(s) - SCM s; -{ - SCM vcell; - SCM answer; - - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol); - vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); - answer = SCM_CAR (vcell); - if (SCM_TYP7 (answer) == scm_tc7_msymbol) - { - if (SCM_REGULAR_STRINGP (s)) - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F; - else - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T; - } - return answer; -} - - -SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol); - -SCM -scm_string_to_obarray_symbol(o, s, softp) - SCM o; - SCM s; - SCM softp; -{ - SCM vcell; - SCM answer; - int softness; - - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2, - s_string_to_obarray_symbol); - SCM_ASSERT((o == SCM_BOOL_F) - || (o == SCM_BOOL_T) - || (SCM_NIMP(o) && SCM_VECTORP(o)), - o, - SCM_ARG1, - s_string_to_obarray_symbol); - - softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F)); - /* iron out some screwy calling conventions */ - if (o == SCM_BOOL_F) - o = scm_symhash; - else if (o == SCM_BOOL_T) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), - (scm_sizet)SCM_ROLENGTH(s), - o, - softness); - if (vcell == SCM_BOOL_F) - return vcell; - answer = SCM_CAR (vcell); - if (SCM_TYP7 (s) == scm_tc7_msymbol) - { - if (SCM_REGULAR_STRINGP (s)) - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F; - else - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T; - } - return answer; -} - -SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol); - -SCM -scm_intern_symbol(o, s) - SCM o; - SCM s; -{ - scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_CAR (sym) == s) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); - } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol); - -SCM -scm_unintern_symbol(o, s) - SCM o; - SCM s; -{ - scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); - SCM_DEFER_INTS; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_CAR (sym) == s) - { - /* Found the symbol to unintern. */ - if (lsym_follow == SCM_BOOL_F) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } - } - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} - -SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding); - -SCM -scm_symbol_binding (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} - - -SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p); - -SCM -scm_symbol_interned_p (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p); - vcell = scm_sym2ovcell_soft (s, o); - if (SCM_IMP(vcell) && (o == scm_symhash)) - vcell = scm_sym2ovcell_soft (s, scm_weak_symhash); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p); - -SCM -scm_symbol_bound_p (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p); - vcell = scm_sym2ovcell_soft (s, o); - return (( SCM_NIMP(vcell) - && (SCM_CDR(vcell) != SCM_UNDEFINED)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x); - -SCM -scm_symbol_set_x (o, s, v) - SCM o; - SCM s; - SCM v; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} - -static void -msymbolize (s) - SCM s; -{ - SCM string; - string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); - SCM_SETCHARS (s, SCM_CHARS (string)); - SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol); - SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F; - SCM_SETCDR (string, SCM_EOL); - SCM_SETCAR (string, SCM_EOL); -} - - -SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref); - -SCM -scm_symbol_fref (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - return SCM_SYMBOL_FUNC (s); -} - - -SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref); - -SCM -scm_symbol_pref (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - return SCM_SYMBOL_PROPS (s); -} - - -SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x); - -SCM -scm_symbol_fset_x (s, val) - SCM s; - SCM val; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - SCM_SYMBOL_FUNC (s) = val; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x); - -SCM -scm_symbol_pset_x (s, val) - SCM s; - SCM val; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_SYMBOL_PROPS (s) = val; - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash); - -SCM -scm_symbol_hash (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash); - return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s)); -} - - - -void -scm_init_symbols () -{ -#include "symbols.x" -} - diff --git a/libguile/symbols.h b/libguile/symbols.h deleted file mode 100644 index f8a75d5f3..000000000 --- a/libguile/symbols.h +++ /dev/null @@ -1,132 +0,0 @@ -/* classes: h_files */ - -#ifndef SYMBOLSH -#define SYMBOLSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern int scm_symhash_dim; - -/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and - SCM_CHARS(SYM) is the address of the first character of SYM's name. - - Beyond that, there are two kinds of symbols: ssymbols and msymbols, - distinguished by the 'S' bit in the type. - - Ssymbols are just uniquified strings. They have a length, chars, - and that's it. They use the scm_tc7_ssymbol tag (S bit clear). - - Msymbols are symbols with extra slots. These slots hold a property - list and a function value (for Emacs Lisp compatibility), a hash - code, and a flag to indicate whether their name contains multibyte - characters. They use the scm_tc7_msymbol tag. - - We'd like SCM_CHARS to work on msymbols just as it does on - ssymbols, so we'll have it point to the symbol's name as usual, and - store a pointer to the slots just before the name in memory. Thus, - you have to do some casting and pointer arithmetic to find the - slots; see the SCM_SLOTS macro. - - In practice, the slots always live just before the pointer to them. - So why not ditch the pointer, and use negative indices to refer to - the slots? That's a good question; ask the author. I think it was - the cognac. */ - -#define SCM_SYMBOLP(x) (SCM_TYP7S(x)==scm_tc7_ssymbol) -#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8) -#define SCM_LENGTH_MAX (0xffffffL) -#define SCM_SETLENGTH(x, v, t) SCM_SETCAR((x), ((v)<<8)+(t)) -#define SCM_SETCHARS SCM_SETCDR -#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) -#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x))) -#define SCM_SLOTS(x) ((SCM *) (* ((SCM *)SCM_CHARS(x) - 1))) -#define SCM_SYMBOL_SLOTS 5 -#define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0]) -#define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1]) -#define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2])) -#define SCM_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3])) - -#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol)) -#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \ - : SCM_CHARS (x)) -#define SCM_ROUCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_UCHARS (SCM_CDDR (x)) \ - : SCM_UCHARS (x)) -#define SCM_ROLENGTH(x) SCM_LENGTH (x) -#define SCM_SUBSTRP(x) ((SCM_TYP7S(x) == scm_tc7_substring)) -#define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) -#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) - - - - -extern unsigned long scm_strhash SCM_P ((unsigned char *str, scm_sizet len, unsigned long n)); -extern SCM scm_sym2vcell SCM_P ((SCM sym, SCM thunk, SCM definep)); -extern SCM scm_sym2ovcell_soft SCM_P ((SCM sym, SCM obarray)); -extern SCM scm_sym2ovcell SCM_P ((SCM sym, SCM obarray)); -extern SCM scm_intern_obarray_soft SCM_P ((char *name, scm_sizet len, SCM obarray, int softness)); -extern SCM scm_intern_obarray SCM_P ((char *name, scm_sizet len, SCM obarray)); -extern SCM scm_intern SCM_P ((char *name, scm_sizet len)); -extern SCM scm_intern0 SCM_P ((char * name)); -extern SCM scm_sysintern SCM_P ((char *name, SCM val)); -extern SCM scm_symbol_p SCM_P ((SCM x)); -extern SCM scm_symbol_to_string SCM_P ((SCM s)); -extern SCM scm_string_to_symbol SCM_P ((SCM s)); -extern SCM scm_string_to_obarray_symbol SCM_P ((SCM o, SCM s, SCM softp)); -extern SCM scm_intern_symbol SCM_P ((SCM o, SCM s)); -extern SCM scm_unintern_symbol SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_binding SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_interned_p SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_bound_p SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_set_x SCM_P ((SCM o, SCM s, SCM v)); -extern SCM scm_symbol_fref SCM_P ((SCM s)); -extern SCM scm_symbol_pref SCM_P ((SCM s)); -extern SCM scm_symbol_fset_x SCM_P ((SCM s, SCM val)); -extern SCM scm_symbol_pset_x SCM_P ((SCM s, SCM val)); -extern SCM scm_symbol_hash SCM_P ((SCM s)); -extern void scm_init_symbols SCM_P ((void)); - -#endif /* SYMBOLSH */ diff --git a/libguile/tag.c b/libguile/tag.c deleted file mode 100644 index 09f0effe5..000000000 --- a/libguile/tag.c +++ /dev/null @@ -1,215 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "struct.h" - -#include "tag.h" - - -SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0); -SCM_CONST_LONG (scm_utag_immediate_char, "utag_immediate_char", 1); -SCM_CONST_LONG (scm_utag_pair, "utag_pair", 2); -SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3); -SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4); -SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5); -SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6); -SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7); -SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8); -SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9); -SCM_CONST_LONG (scm_utag_ivect, "utag_ivect", 10); -SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11); -SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12); -SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13); -SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14); -SCM_CONST_LONG (scm_utag_string, "utag_string", 15); -SCM_CONST_LONG (scm_utag_mb_string, "utag_mb_string", 16); -SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17); -SCM_CONST_LONG (scm_utag_mb_substring, "utag_mb_substring", 18); -SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19); -SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20); -SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21); -SCM_CONST_LONG (scm_utag_cxr, "utag_cxr", 22); -SCM_CONST_LONG (scm_utag_subr_3, "utag_subr_3", 23); -SCM_CONST_LONG (scm_utag_subr_2, "utag_subr_2", 24); -SCM_CONST_LONG (scm_utag_rpsubr, "utag_rpsubr", 25); -SCM_CONST_LONG (scm_utag_subr_1o, "utag_subr_1o", 26); -SCM_CONST_LONG (scm_utag_subr_2o, "utag_subr_2o", 27); -SCM_CONST_LONG (scm_utag_lsubr_2, "utag_lsubr_2", 28); -SCM_CONST_LONG (scm_utag_lsubr, "utag_lsubr", 29); -SCM_CONST_LONG (scm_utag_smob_base, "utag_smob_base", 252); -SCM_CONST_LONG (scm_utag_port_base, "utag_port_base", 253); -SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254); -SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255); - - -SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag); - -SCM -scm_tag (x) - SCM x; -{ - switch (SCM_ITAG3 (x)) - { - case scm_tc3_int_1: - case scm_tc3_int_2: - return SCM_CDR (scm_utag_immediate_integer) ; - - case scm_tc3_imm24: - if (SCM_ICHRP (x)) - return SCM_CDR (scm_utag_immediate_char) ; - else - { - int tag; - tag = SCM_MAKINUM ((x >> 8) & 0xff); - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8)); - } - - case scm_tc3_cons: - switch (SCM_TYP7 (x)) - { - case scm_tcs_cons_nimcar: - return SCM_CDR (scm_utag_pair) ; - case scm_tcs_closures: - return SCM_CDR (scm_utag_closure) ; - case scm_tcs_symbols: - return SCM_CDR (scm_utag_symbol) ; - case scm_tc7_vector: - return SCM_CDR (scm_utag_vector) ; - case scm_tc7_wvect: - return SCM_CDR (scm_utag_wvect) ; - case scm_tc7_bvect: - return SCM_CDR (scm_utag_bvect) ; - case scm_tc7_byvect: - return SCM_CDR (scm_utag_byvect) ; - case scm_tc7_svect: - return SCM_CDR (scm_utag_svect) ; - case scm_tc7_ivect: - return SCM_CDR (scm_utag_ivect) ; - case scm_tc7_uvect: - return SCM_CDR (scm_utag_uvect) ; - case scm_tc7_fvect: - return SCM_CDR (scm_utag_fvect) ; - case scm_tc7_dvect: - return SCM_CDR (scm_utag_dvect) ; - case scm_tc7_cvect: - return SCM_CDR (scm_utag_cvect) ; - case scm_tc7_string: - return SCM_CDR (scm_utag_string) ; - case scm_tc7_mb_string: - return SCM_CDR (scm_utag_mb_string) ; - case scm_tc7_substring: - return SCM_CDR (scm_utag_substring) ; - case scm_tc7_mb_substring: - return SCM_CDR (scm_utag_mb_substring) ; - case scm_tc7_asubr: - return SCM_CDR (scm_utag_asubr) ; - case scm_tc7_subr_0: - return SCM_CDR (scm_utag_subr_0) ; - case scm_tc7_subr_1: - return SCM_CDR (scm_utag_subr_1) ; - case scm_tc7_cxr: - return SCM_CDR (scm_utag_cxr) ; - case scm_tc7_subr_3: - return SCM_CDR (scm_utag_subr_3) ; - case scm_tc7_subr_2: - return SCM_CDR (scm_utag_subr_2) ; - case scm_tc7_rpsubr: - return SCM_CDR (scm_utag_rpsubr) ; - case scm_tc7_subr_1o: - return SCM_CDR (scm_utag_subr_1o) ; - case scm_tc7_subr_2o: - return SCM_CDR (scm_utag_subr_2o) ; - case scm_tc7_lsubr_2: - return SCM_CDR (scm_utag_lsubr_2) ; - case scm_tc7_lsubr: - return SCM_CDR (scm_utag_lsubr) ; - - case scm_tc7_port: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_port_base)) | (tag << 8)); - } - case scm_tc7_smob: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) | (tag << 8)); - } - case scm_tcs_cons_gloc: - /* must be a struct */ - { - int tag; - tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag]; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) | (tag << 8)); - } - return SCM_CDR (scm_utag_struct_base) ; - - default: - if (SCM_CONSP (x)) - return SCM_CDR (scm_utag_pair); - else - return SCM_MAKINUM (-1); - } - - case scm_tc3_cons_gloc: - case scm_tc3_tc7_1: - case scm_tc3_tc7_2: - case scm_tc3_closure: - /* Never reached */ - break; - } - return SCM_MAKINUM (-1); -} - - - - - -void -scm_init_tag () -{ -#include "tag.x" -} - diff --git a/libguile/tag.h b/libguile/tag.h deleted file mode 100644 index 9c4952bdf..000000000 --- a/libguile/tag.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef TAGH -#define TAGH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_tag SCM_P ((SCM x)); -extern void scm_init_tag SCM_P ((void)); - -#endif /* TAGH */ diff --git a/libguile/tags.h b/libguile/tags.h deleted file mode 100644 index 1b21ba8c9..000000000 --- a/libguile/tags.h +++ /dev/null @@ -1,539 +0,0 @@ -/* classes: h_files */ - -#ifndef TAGSH -#define TAGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -/** This file defines the format of SCM values and cons pairs. - ** It is here that tag bits are assigned for various purposes. - **/ - - - -/* In the beginning was the Word: - */ -typedef long SCM; - - - -/* Cray machines have pointers that are incremented once for each word, - * rather than each byte, the 3 most significant bits encode the byte - * within the word. The following macros deal with this by storing the - * native Cray pointers like the ones that looks like scm expects. This - * is done for any pointers that might appear in the car of a scm_cell, pointers - * to scm_vector elts, functions, &c are not munged. - */ -#ifdef _UNICOS -# define SCM2PTR(x) ((int)(x) >> 3) -# define PTR2SCM(x) (((SCM)(x)) << 3) -# define SCM_POINTERS_MUNGED -#else -# define SCM2PTR(x) (x) -# define PTR2SCM(x) ((SCM)(x)) -#endif /* def _UNICOS */ - - -/* SCM variables can contain: - * - * Non-objects -- meaning that the tag-related macros don't apply to them - * in the usual way. - * - * Immediates -- meaning that the variable contains an entire Scheme object. - * - * Non-immediates -- meaning that the variable holds a (possibly - * tagged) pointer into the cons pair heap. - * - * Non-objects are distinguished from other values by careful coding - * only (i.e., programmers must keep track of any SCM variables they - * create that don't contain ordinary scheme values). - * - * All immediates and non-immediates must have a 0 in bit 0. Only - * non-object values can have a 1 in bit 0. In some cases, bit 0 of a - * word in the heap is used for the GC tag so during garbage - * collection, that bit might be 1 even in an immediate or - * non-immediate value. In other cases, bit 0 of a word in the heap - * is used to tag a pointer to a GLOC (VM global variable address) or - * the header of a struct. But whenever an SCM variable holds a - * normal Scheme value, bit 0 is 0. - * - * Immediates and non-immediates are distinguished by bits two and four. - * Immediate values must have a 1 in at least one of those bits. Does - * this (or any other detail of tagging) seem arbitrary? Try changing it! - * (Not always impossible but it is fair to say that many details of tags - * are mutually dependent). */ - -#define SCM_IMP(x) (6 & (int)(x)) -#define SCM_NIMP(x) (!SCM_IMP(x)) - -/* Here is a summary of tagging in SCM values as they might occur in - * SCM variables or in the heap. - * - * low bits meaning - * - * - * 0 Most objects except... - * 1 ...glocs and structs (this tag valid only in a SCM_CAR or - * in the header of a struct's data). - * - * 00 heap addresses and many immediates (not integers) - * 01 glocs/structs, some tc7_ codes - * 10 immediate integers - * 11 various tc7_ codes including, tc16_ codes. - * - * - * 000 heap address - * 001 glocs/structs - * 010 integer - * 011 closure - * 100 immediates - * 101 tc7_ - * 110 integer - * 111 tc7_ - * - * - * 100 --- IMMEDIATES - * - * Looking at the seven final bits of an immediate: - * - * 0000-100 short instruction - * 0001-100 short instruction - * 0010-100 short instruction - * 0011-100 short instruction - * 0100-100 short instruction - * 0101-100 short instruction - * 0110-100 various immediates and long instructions - * 0111-100 short instruction - * 1000-100 short instruction - * 1001-100 short instruction - * 1010-100 short instruction - * 1011-100 short instruction - * 1100-100 short instruction - * 1101-100 short instruction - * 1110-100 immediate characters - * 1111-100 ilocs - * - * Some of the 0110100 immediates are long instructions (they dispatch - * in two steps compared to one step for a short instruction). - * The two steps are, (1) dispatch on 7 bits to the long instruction - * handler, (2) dispatch on 7 additional bits. - * - * One way to think of it is that there are 128 short instructions, - * with the 13 immediates above being some of the most interesting. - * - * Also noteworthy are the groups of 16 7-bit instructions implied by - * some of the 3-bit tags. For example, closure references consist - * of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit - * instructions, all ending 011, which are invoked by evaluating closures. - * - * In other words, if you hand the evaluator a closure, the evaluator - * treats the closure as a graph of virtual machine instructions. - * A closure is a pair with a pointer to the body of the procedure - * in the CDR and a pointer to the environment of the closure in the CAR. - * The environment pointer is tagged 011 which implies that the least - * significant 7 bits of the environment pointer also happen to be - * a virtual machine instruction we could call "SELF" (for self-evaluating - * object). - * - * A less trivial example are the 16 instructions ending 000. If those - * bits tag the CAR of a pair, then evidently the pair is an ordinary - * cons pair and should be evaluated as a procedure application. The sixteen, - * 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier. - * For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY - * instruction will, as a side effect, overwrite that CAR with a new instruction - * that contains a cached address for the variable named by the symbol.) - * - * Here is a summary of tags in the CAR of a non-immediate: - * - * HEAP CELL: G=gc_mark; 1 during mark, 0 other times. - * - * cons ..........SCM car..............0 ...........SCM cdr.............G - * gloc ..........SCM vcell..........001 ...........SCM cdr.............G - * struct ..........void * type........001 ...........void * data.........G - * closure ..........SCM code...........011 ...........SCM env.............G - * tc7 .........long length....GxxxD1S1 ..........void *data............ - * - * - * - * 101 & 111 --- tc7_ types - * - * tc7_tags are 7 bit tags ending in 1x1. These tags - * occur only in the CAR of heap cells, and have the - * handy property that all bits of the CAR above the - * bottom eight can be used to store a length, thus - * saving a word in the body itself. Thus, we use them - * for strings, symbols, and vectors (among other - * things). - * - * SCM_LENGTH returns the bits in "length" (see the diagram). - * SCM_CHARS returns the data cast to "char *" - * SCM_CDR returns the data cast to "SCM" - * TYP7(X) returns bits 0...6 of SCM_CAR (X) - * - * For the interpretation of SCM_LENGTH and SCM_CHARS - * that applies to a particular type, see the header file - * for that type. - * - * Sometimes we choose the bottom seven bits carefully, - * so that the 4- and 1-valued bits (called the D and S - * bits) can be masked off to reveal a common type. - * - * TYP7S(X) returns TYP7, but masking out the option bit S. - * TYP7D(X) returns TYP7, but masking out the option bit D. - * TYP7SD(X) masks out both option bits. - * - * For example, all strings have 001 in the 'xxx' bits in - * the diagram above, the D bit says whether it's a - * substring, and the S bit says whether it's a multibyte - * character string. - * - * for example: - * D S - * scm_tc7_string = G0010101 - * scm_tc7_mb_string = G0010111 - * scm_tc7_substring = G0011101 - * scm_tc7_mb_substring = G0011111 - * - * TYP7DS turns all string tags into tc7_string; thus, - * testing TYP7DS against tc7_string is a quick way to - * test for any kind of string. - * - * TYP7S turns tc7_mb_string into tc7_string and - * tc7_mb_substring into tc7_substring. - * - * TYP7D turns tc7_mb_substring into tc7_mb_string and - * tc7_substring into tc7_string. - * - * Some TC7 types are subdivided into 256 subtypes giving - * rise to the macros: - * - * TYP16 - * TYP16S - * GCTYP16 - * - * TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7, - * but a different option bit is used (bit 2 for TYP7S, - * bit 8 for TYP16S). - * */ - - - - -/* {Non-immediate values.} - * - * If X is non-immediate, it is necessary to look at SCM_CAR (X) to - * figure out Xs type. X may be a cons pair, in which case the - * value SCM_CAR (x) will be either an immediate or non-immediate value. - * X may be something other than a cons pair, in which case the value SCM_CAR (x) - * will be a non-object value. - * - * All immediates and non-immediates have a 0 in bit 0. We additionally preserve - * the invariant that all non-object values stored in the SCM_CAR of a non-immediate - * object have a 1 in bit 1: - */ - -#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x)) -#define SCM_CONSP(x) (!SCM_NCONSP(x)) - - -/* ECONSP is historical and, in fact, slightly buggy. - * There are two places to fix where structures and glocs can be confused. - * !!! - */ -#define SCM_ECONSP(x) (SCM_CONSP(x) || (1==SCM_TYP3(x))) -#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x))) - - - -#define SCM_CELLP(x) (!SCM_NCELLP(x)) -#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x)) - -/* See numbers.h for macros relating to immediate integers. - */ - -#define SCM_ITAG3(x) (7 & (int)x) -#define SCM_TYP3(x) (7 & (int)SCM_CAR(x)) -#define scm_tc3_cons 0 -#define scm_tc3_cons_gloc 1 -#define scm_tc3_int_1 2 -#define scm_tc3_closure 3 -#define scm_tc3_imm24 4 -#define scm_tc3_tc7_1 5 -#define scm_tc3_int_2 6 -#define scm_tc3_tc7_2 7 - - -/* - * Do not change the three bit tags. - */ - - -#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) -#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x)) -#define SCM_TYP7SD(x) (0x75 & (int)SCM_CAR(x)) -#define SCM_TYP7D(x) (0x77 & (int)SCM_CAR(x)) - - -#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x)) -#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x)) -#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x)) - - - -/* Testing and Changing GC Marks in Various Standard Positions - */ -#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x)) -#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x)) -#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x,1) -#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L) -#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80) -#define SCM_CLRGC8MARK(x) SCM_SETAND_CAR (x, ~0x80L) - - - - -/* couple */ -#define scm_tc7_ssymbol 5 -#define scm_tc7_msymbol 7 - -/* couple */ -#define scm_tc7_vector 13 -#define scm_tc7_wvect 15 - -/* a quad, two couples, two trists */ -#define scm_tc7_string 21 -#define scm_tc7_mb_string 23 -#define scm_tc7_substring 29 -#define scm_tc7_mb_substring 31 - -/* Many of the following should be turned - * into structs or smobs. We need back some - * of these 7 bit tags! - */ -#define scm_tc7_uvect 37 -#define scm_tc7_lvector 39 -#define scm_tc7_fvect 45 -#define scm_tc7_dvect 47 -#define scm_tc7_cvect 53 -#define scm_tc7_svect 55 -#define scm_tc7_contin 61 -#define scm_tc7_cclo 63 -#define scm_tc7_rpsubr 69 -#define scm_tc7_bvect 71 -#define scm_tc7_byvect 77 -#define scm_tc7_ivect 79 -#define scm_tc7_subr_0 85 -#define scm_tc7_subr_1 87 -#define scm_tc7_cxr 93 -#define scm_tc7_subr_3 95 -#define scm_tc7_subr_2 101 -#define scm_tc7_asubr 103 -#define scm_tc7_subr_1o 109 -#define scm_tc7_subr_2o 111 -#define scm_tc7_lsubr_2 117 -#define scm_tc7_lsubr 119 - - -/* There are 256 port subtypes. Here are the first four. - * These must agree with the init function in ports.c - */ -#define scm_tc7_port 125 - -/* fports and pipes form an intended TYP16S equivelancy - * group (similar to a tc7 "couple". - */ -#define scm_tc16_fport (scm_tc7_port + 0*256L) -#define scm_tc16_pipe (scm_tc7_port + 1*256L) - -#define scm_tc16_strport (scm_tc7_port + 2*256L) -#define scm_tc16_sfport (scm_tc7_port + 3*256L) - - -/* There are 256 smob subtypes. Here are the first four. - */ - -#define scm_tc7_smob 127 /* DO NOT CHANGE [**] */ - -/* [**] If you change scm_tc7_smob, you must also change - * the places it is hard coded in this file and possibly others. - */ - - -/* scm_tc_free_cell is also the 0th smob type. - */ -#define scm_tc_free_cell 127 - -/* The 1st smob type: - */ -#define scm_tc16_flo 0x017f -#define scm_tc_flo 0x017fL - -/* Some option bits begeinning at bit 16 of scm_tc16_flo: - */ -#define SCM_REAL_PART (1L<<16) -#define SCM_IMAG_PART (2L<<16) -#define scm_tc_dblr (scm_tc16_flo|SCM_REAL_PART) -#define scm_tc_dblc (scm_tc16_flo|SCM_REAL_PART|SCM_IMAG_PART) - - -/* Smob types 2 and 3: - */ -#define scm_tc16_bigpos 0x027f -#define scm_tc16_bigneg 0x037f - - - -/* {Immediate Values} - */ - -enum scm_tags -{ - scm_tc8_char = 0xf4, - scm_tc8_iloc = 0xfc, -}; - -#define SCM_ITAG8(X) ((int)(X) & 0xff) -#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG) -#define SCM_ITAG8_DATA(X) ((X)>>8) - - - -/* Immediate Symbols, Special Symbols, Flags (various constants). - */ - -/* SCM_ISYMP tests for ISPCSYM and ISYM */ -#define SCM_ISYMP(n) ((0x187 & (int)(n))==4) - -/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */ -#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4) -#define SCM_ISYMNUM(n) ((int)((n)>>9)) -#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)]) -#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) -#define SCM_MAKISYM(n) (((n)<<9)+0x74L) -#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L) - -/* This table must agree with the declarations - * in repl.c: {Names of immediate symbols}. - * - * These are used only in eval but their values - * have to be allocated here. - * - */ - -#define SCM_IM_AND SCM_MAKSPCSYM(0) -#define SCM_IM_BEGIN SCM_MAKSPCSYM(1) -#define SCM_IM_CASE SCM_MAKSPCSYM(2) -#define SCM_IM_COND SCM_MAKSPCSYM(3) -#define SCM_IM_DO SCM_MAKSPCSYM(4) -#define SCM_IM_IF SCM_MAKSPCSYM(5) -#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6) -#define SCM_IM_LET SCM_MAKSPCSYM(7) -#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8) -#define SCM_IM_LETREC SCM_MAKSPCSYM(9) -#define SCM_IM_OR SCM_MAKSPCSYM(10) -#define SCM_IM_QUOTE SCM_MAKSPCSYM(11) -#define SCM_IM_SET SCM_MAKSPCSYM(12) -#define SCM_IM_DEFINE SCM_MAKSPCSYM(13) -#define SCM_IM_APPLY SCM_MAKISYM(14) -#define SCM_IM_CONT SCM_MAKISYM(15) -#define SCM_BOOL_F SCM_MAKIFLAG(16) -#define SCM_BOOL_T SCM_MAKIFLAG(17) -#define SCM_UNDEFINED SCM_MAKIFLAG(18) -#define SCM_EOF_VAL SCM_MAKIFLAG(19) -#define SCM_EOL SCM_MAKIFLAG(20) -#define SCM_UNSPECIFIED SCM_MAKIFLAG(21) - - -#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x)) - - - -/* Dispatching aids: - */ - - -/* For cons pairs with immediate values in the CAR - */ - -#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\ - case 12:case 14:case 18:case 20:\ - case 22:case 26:case 28:case 30:\ - case 34:case 36:case 38:case 42:\ - case 44:case 46:case 50:case 52:\ - case 54:case 58:case 60:case 62:\ - case 66:case 68:case 70:case 74:\ - case 76:case 78:case 82:case 84:\ - case 86:case 90:case 92:case 94:\ - case 98:case 100:case 102:case 106:\ - case 108:case 110:case 114:case 116:\ - case 118:case 122:case 124:case 126 - -/* For cons pairs with non-immediate values in the SCM_CAR - */ -#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\ - case 32:case 40:case 48:case 56:\ - case 64:case 72:case 80:case 88:\ - case 96:case 104:case 112:case 120 - -/* A CONS_GLOC occurs in code. It's CAR is a pointer to the - * CDR of a variable. The low order bits of the CAR are 001. - * The CDR of the gloc is the code continuation. - */ -#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ - case 33:case 41:case 49:case 57:\ - case 65:case 73:case 81:case 89:\ - case 97:case 105:case 113:case 121 - -#define scm_tcs_closures 3:case 11:case 19:case 27:\ - case 35:case 43:case 51:case 59:\ - case 67:case 75:case 83:case 91:\ - case 99:case 107:case 115:case 123 - -#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ - case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ - case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr - -#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol - -#define scm_tcs_bignums scm_tc16_bigpos:case scm_tc16_bigneg - -#endif /* TAGSH */ diff --git a/libguile/throw.c b/libguile/throw.c deleted file mode 100644 index 7e67df4da..000000000 --- a/libguile/throw.c +++ /dev/null @@ -1,496 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" -#include "alist.h" -#include "eval.h" -#include "dynwind.h" -#include "backtrace.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "continuations.h" -#include "stackchk.h" - -#include "throw.h" - - -/* {Catch and Throw} - */ -static int scm_tc16_jmpbuffer; - -#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) -#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) -#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) -#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) - -#ifndef DEBUG_EXTENSIONS -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) -#define SETJBJMPBUF SCM_SETCDR -#else -#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) -#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) -#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) - -static scm_sizet freejb SCM_P ((SCM jbsmob)); - -static scm_sizet -freejb (jbsmob) - SCM jbsmob; -{ - scm_must_free ((char *) SCM_CDR (jbsmob)); - return sizeof (scm_cell); -} -#endif - -static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -static int -printjb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); - scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port); - scm_intprint((SCM) JBJMPBUF(exp), 16, port); - scm_gen_putc ('>', port); - return 1 ; -} - -static scm_smobfuns jbsmob = { - scm_mark0, -#ifdef DEBUG_EXTENSIONS - freejb, -#else - scm_free0, -#endif - printjb, - 0 -}; - -static SCM make_jmpbuf SCM_P ((void)); -static SCM -make_jmpbuf () -{ - SCM answer; - SCM_NEWCELL (answer); - SCM_REDEFER_INTS; - { -#ifdef DEBUG_EXTENSIONS - char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); - SCM_SETCDR (answer, (SCM) mem); -#endif - SCM_SETCAR (answer, scm_tc16_jmpbuffer); - SETJBJMPBUF(answer, (jmp_buf *)0); - DEACTIVATEJB(answer); - } - SCM_REALLOW_INTS; - return answer; -} - -struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ -{ - jmp_buf buf; /* must be first */ - SCM throw_tag; - SCM retval; -}; - - -/* scm_internal_catch is the guts of catch. It handles all the - mechanics of setting up a catch target, invoking the catch body, - and perhaps invoking the handler if the body does a throw. - - The function is designed to be usable from C code, but is general - enough to implement all the semantics Guile Scheme expects from - throw. - - TAG is the catch tag. Typically, this is a symbol, but this - function doesn't actually care about that. - - BODY is a pointer to a C function which runs the body of the catch; - this is the code you can throw from. We call it like this: - BODY (DATA, JMPBUF) - where: - DATA is just the DATA argument we received; we pass it through - to BODY as its first argument. The caller can make DATA point - to anything useful that BODY might need. - JMPBUF is the Scheme jmpbuf object corresponding to this catch, - which we have just created and initialized. - - HANDLER is a pointer to a C function to deal with a throw to TAG, - should one occur. We call it like this: - HANDLER (DATA, TAG, THROW_ARGS) - where - DATA is the DATA argument we recevied, as for BODY above. - TAG is the tag that the user threw to; usually this is TAG, but - it could be something else if TAG was #t (i.e., a catch-all), - or the user threw to a jmpbuf. - THROW_ARGS is the list of arguments the user passed to the THROW - function. - - DATA is just a pointer we pass through to BODY and (if we call it) - HANDLER. We don't actually use it otherwise ourselves. The idea - is that, if our caller wants to communicate something to BODY and - HANDLER, it can pass a pointer to it as DATA, which BODY and - HANDLER can then use. Think of it as a way to make BODY and - HANDLER closures, not just functions; DATA points to the enclosed - variables. */ - -SCM -scm_internal_catch (tag, body, handler, data) - SCM tag; - scm_catch_body_t body; - scm_catch_handler_t handler; - void *data; -{ - struct jmp_buf_and_retval jbr; - SCM jmpbuf; - SCM answer; - - jmpbuf = make_jmpbuf (); - answer = SCM_EOL; - scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); - SETJBJMPBUF(jmpbuf, &jbr.buf); -#ifdef DEBUG_EXTENSIONS - SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); -#endif - if (setjmp (jbr.buf)) - { - SCM throw_tag; - SCM throw_args; - -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - SCM_REDEFER_INTS; - DEACTIVATEJB (jmpbuf); - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - throw_args = jbr.retval; - throw_tag = jbr.throw_tag; - jbr.throw_tag = SCM_EOL; - jbr.retval = SCM_EOL; - answer = handler (data, throw_tag, throw_args); - } - else - { - ACTIVATEJB (jmpbuf); - answer = body (data, jmpbuf); - SCM_REDEFER_INTS; - DEACTIVATEJB (jmpbuf); - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - } - return answer; -} - - -/* scm_catch passes a pointer to one of these structures through to - its body and handler routines, to tell them what to do. */ -struct catch_body_data -{ - /* The tag being caught. We only use it to figure out what - arguments to pass to the body procedure; see catch_body for - details. */ - SCM tag; - - /* The Scheme procedure object constituting the catch body. - catch_body invokes this. */ - SCM body_proc; - - /* The Scheme procedure object we invoke to handle throws. */ - SCM handler_proc; -}; - - -/* This function runs the catch body. DATA contains the Scheme - procedure to invoke. If the tag being caught is #f, then we pass - JMPBUF to the body procedure; otherwise, it gets no arguments. */ -static SCM catch_body SCM_P ((void *, SCM)); - -static SCM -catch_body (data, jmpbuf) - void *data; - SCM jmpbuf; -{ - struct catch_body_data *c = (struct catch_body_data *) data; - - if (c->tag == SCM_BOOL_F) - return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL); - else - return scm_apply (c->body_proc, SCM_EOL, SCM_EOL); -} - - -/* If the user does a throw to this catch, this function runs the - handler. DATA says which Scheme procedure object to invoke. */ -static SCM catch_handler SCM_P ((void *, SCM, SCM)); - -static SCM -catch_handler (data, tag, throw_args) - void *data; - SCM tag; - SCM throw_args; -{ - struct catch_body_data *c = (struct catch_body_data *) data; - - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); -} - - -SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); -SCM -scm_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; -{ - struct catch_body_data c; - - SCM_ASSERT ((tag == SCM_BOOL_F) - || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_catch); - - c.tag = tag; - c.body_proc = thunk; - c.handler_proc = handler; - - /* scm_internal_catch takes care of all the mechanics of setting up - a catch tag; we tell it to call catch_body to run the body, and - catch_handler to deal with any throws to this catch. Both those - functions receive the pointer to c, which tells them the details - of how to behave. */ - return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c); -} - -SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); -SCM -scm_lazy_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; -{ - SCM answer; - SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_lazy_catch); - SCM_REDEFER_INTS; - scm_dynwinds = scm_acons (tag, handler, scm_dynwinds); - SCM_REALLOW_INTS; - answer = scm_apply (thunk, SCM_EOL, SCM_EOL); - SCM_REDEFER_INTS; - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - return answer; -} - -/* The user has thrown to an uncaught key --- print a message and die. - 1) If the user wants something different, they can use (catch #t - ...) to do what they like. - 2) Outside the context of a read-eval-print loop, there isn't - anything else good to do; libguile should not assume the existence - of a read-eval-print loop. - 3) Given that we shouldn't do anything complex, it's much more - robust to do it in C code. */ -static SCM uncaught_throw SCM_P ((SCM key, SCM args)); -static SCM -uncaught_throw (key, args) - SCM key; - SCM args; -{ - SCM p = scm_def_errp; - - if (scm_ilength (args) >= 3) - { - SCM message = SCM_CADR (args); - SCM parts = SCM_CADDR (args); - - scm_gen_puts (scm_regular_string, "guile: ", p); - scm_display_error_message (message, parts, p); - } - else - { - scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); - scm_prin1 (key, p, 0); - scm_gen_puts (scm_regular_string, ": ", p); - scm_prin1 (args, p, 1); - scm_gen_putc ('\n', p); - } - - exit (2); -} - - -static char s_throw[]; -SCM -scm_ithrow (key, args, noreturn) - SCM key; - SCM args; - int noreturn; -{ - SCM jmpbuf; - SCM wind_goal; - - if (SCM_NIMP (key) && SCM_JMPBUFP (key)) - { - jmpbuf = key; - if (noreturn) - { - SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf, - "throw to dynamically inactive catch", - s_throw); - } - else if (!JBACTIVE (jmpbuf)) - return SCM_UNSPECIFIED; - } - else - { - SCM dynpair = SCM_UNDEFINED; - SCM winds; - - if (noreturn) - { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, - s_throw); - } - else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key))) - return SCM_UNSPECIFIED; - - /* Search the wind list for an appropriate catch. - "Waiter, please bring us the wind list." */ - for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds)) - { - if (! SCM_CONSP (winds)) - abort (); - - dynpair = SCM_CAR (winds); - if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair)) - { - SCM this_key = SCM_CAR (dynpair); - - if (this_key == SCM_BOOL_T || this_key == key) - break; - } - } - - /* If we didn't find anything, print a message and exit Guile. */ - if (winds == SCM_EOL) - uncaught_throw (key, args); - - if (SCM_IMP (winds) || SCM_NCONSP (winds)) - abort (); - - if (dynpair != SCM_BOOL_F) - jmpbuf = SCM_CDR (dynpair); - else - { - if (!noreturn) - return SCM_UNSPECIFIED; - else - { - scm_exitval = scm_cons (key, args); - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (scm_rootcont); -#endif - longjmp (SCM_JMPBUF (scm_rootcont), 1); - } - } - } - for (wind_goal = scm_dynwinds; - SCM_CDAR (wind_goal) != jmpbuf; - wind_goal = SCM_CDR (wind_goal)) - ; - if (!SCM_JMPBUFP (jmpbuf)) - { - SCM oldwinds = scm_dynwinds; - SCM handle, answer; - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - SCM_REDEFER_INTS; - handle = scm_dynwinds; - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - answer = scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL); - SCM_REDEFER_INTS; - SCM_SETCDR (handle, scm_dynwinds); - scm_dynwinds = handle; - SCM_REALLOW_INTS; - scm_dowinds (oldwinds, scm_ilength (scm_dynwinds) - scm_ilength (oldwinds)); - return answer; - } - else - { - struct jmp_buf_and_retval * jbr; - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); - jbr->throw_tag = key; - jbr->retval = args; - } -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); -#endif - longjmp (*JBJMPBUF (jmpbuf), 1); -} - - -SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); -SCM -scm_throw (key, args) - SCM key; - SCM args; -{ - /* May return if handled by lazy catch. */ - return scm_ithrow (key, args, 1); -} - - -void -scm_init_throw () -{ - scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); -#include "throw.x" -} diff --git a/libguile/throw.h b/libguile/throw.h deleted file mode 100644 index 83d8e946d..000000000 --- a/libguile/throw.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef THROWH -#define THROWH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -typedef SCM (*scm_catch_body_t) SCM_P ((void *data, SCM jmpbuf)); -typedef SCM (*scm_catch_handler_t) SCM_P ((void *data, - SCM tag, SCM throw_args)); - -extern SCM scm_internal_catch SCM_P ((SCM tag, - scm_catch_body_t body, - scm_catch_handler_t handler, - void *data)); - -extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); -extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); -extern SCM scm_ithrow SCM_P ((SCM key, SCM args, int noreturn)); -extern SCM scm_throw SCM_P ((SCM key, SCM args)); -extern void scm_init_throw SCM_P ((void)); -#endif /* THROWH */ diff --git a/libguile/unif.c b/libguile/unif.c deleted file mode 100644 index 922101722..000000000 --- a/libguile/unif.c +++ /dev/null @@ -1,2538 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "eval.h" -#include "genio.h" -#include "smob.h" -#include "sequences.h" -#include "strop.h" -#include "feature.h" - -#include "unif.h" -#include "ramap.h" - - -/* The set of uniform scm_vector types is: - * Vector of: Called: - * unsigned char string - * char byvect - * boolean bvect - * signed int ivect - * unsigned int uvect - * float fvect - * double dvect - * complex double cvect - * short svect - * long_long llvect - */ - -long scm_tc16_array; - -/* - * This complicates things too much if allowed on any array. - * C code can safely call it on arrays known to be used in a single - * threaded manner. - * - * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); - */ -static char s_vector_set_length_x[] = "vector-set-length!"; - - -SCM -scm_vector_set_length_x (vect, len) - SCM vect; - SCM len; -{ - long l; - scm_sizet siz; - scm_sizet sz; - - l = SCM_INUM (len); - SCM_ASRTGO (SCM_NIMP (vect), badarg1); - switch (SCM_TYP7 (vect)) - { - default: - badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x); - case scm_tc7_string: - case scm_tc7_mb_string: - SCM_ASRTGO (vect != scm_nullstr, badarg1); - sz = sizeof (char); - l++; - break; - case scm_tc7_vector: - SCM_ASRTGO (vect != scm_nullvect, badarg1); - sz = sizeof (SCM); - break; -#ifdef ARRAYS - case scm_tc7_bvect: - l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_byvect: - sz = sizeof (char); - break; - - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif -#endif - } - SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x); - if (!l) - l = 1L; - siz = l * sz; - if (siz != l * sz) - scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x); - SCM_REDEFER_INTS; - SCM_SETCHARS (vect, - ((char *) - scm_must_realloc (SCM_CHARS (vect), - (long) SCM_LENGTH (vect) * sz, - (long) siz, - s_vector_set_length_x))); - if (SCM_VECTORP (vect)) - { - sz = SCM_LENGTH (vect); - while (l > sz) - SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED; - } - else if (SCM_STRINGP (vect)) - SCM_CHARS (vect)[l - 1] = 0; - SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect)); - SCM_REALLOW_INTS; - return vect; -} - - -#ifdef ARRAYS - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - - -SCM -scm_makflo (x) - float x; -{ - SCM z; - if (x == 0.0) - return scm_flo0; - SCM_NEWCELL (z); - SCM_DEFER_INTS; - SCM_SETCAR (z, scm_tc_flo); - SCM_FLO (z) = x; - SCM_ALLOW_INTS; - return z; -} -#endif -#endif - - -SCM -scm_make_uve (k, prot) - long k; - SCM prot; -{ - SCM v; - long i, type; - if (SCM_BOOL_T == prot) - { - i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - type = scm_tc7_bvect; - } - else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0'))) - { - i = sizeof (char) * k; - type = scm_tc7_byvect; - } - else if (SCM_ICHRP (prot)) - { - i = sizeof (char) * k; - type = scm_tc7_string; - } - else if (SCM_INUMP (prot)) - { - i = sizeof (long) * k; - if (SCM_INUM (prot) > 0) - type = scm_tc7_uvect; - else - type = scm_tc7_ivect; - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot))) - { - char s; - - s = SCM_CHARS (prot)[0]; - if (s == 's') - { - i = sizeof (short) * k; - type = scm_tc7_svect; - } -#ifdef LONGLONGS - else if (s == 'l') - { - i = sizeof (long_long) * k; - type = scm_tc7_llvect; - } -#endif - else - { - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); - } - } - else -#ifdef SCM_FLOATS - if (SCM_IMP (prot) || !SCM_INEXP (prot)) -#endif - /* Huge non-unif vectors are NOT supported. */ - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); /* no special scm_vector */ -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - else if (SCM_SINGP (prot)) - - { - i = sizeof (float) * k; - type = scm_tc7_fvect; - } -#endif - else if (SCM_CPLXP (prot)) - { - i = 2 * sizeof (double) * k; - type = scm_tc7_cvect; - } - else - { - i = sizeof (double) * k; - type = scm_tc7_dvect; - } -#endif - - SCM_NEWCELL (v); - SCM_DEFER_INTS; - { - char *m; - m = scm_must_malloc ((i ? i : 1L), "vector"); - SCM_SETCHARS (v, (char *) m); - } - SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type); - SCM_ALLOW_INTS; - return v; -} - -SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length); - -SCM -scm_uniform_vector_length (v) - SCM v; -{ - SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length); - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return SCM_MAKINUM (SCM_LENGTH (v)); - } -} - -SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p); - -SCM -scm_array_p (v, prot) - SCM v; - SCM prot; -{ - int nprot; - int enclosed; - nprot = SCM_UNBNDP (prot); - enclosed = 0; - if (SCM_IMP (v)) - return SCM_BOOL_F; -loop: - switch (SCM_TYP7 (v)) - { - case scm_tc7_smob: - if (!SCM_ARRAYP (v)) - return SCM_BOOL_F; - if (nprot) - return SCM_BOOL_T; - if (enclosed++) - return SCM_BOOL_F; - v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_bvect: - return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_string: - return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_byvect: - return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_uvect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_ivect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_svect: - return ( nprot - || (SCM_NIMP (prot) - && SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); -#ifdef LONGLONGS - case scm_tc7_llvect: - return ( nprot - || (SCM_NIMP (prot) - && SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); -#endif -# ifdef SCM_FLOATS -# ifdef SCM_SINGLES - case scm_tc7_fvect: - return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif - case scm_tc7_dvect: - return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_cvect: - return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif - case scm_tc7_vector: - return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F; - default:; - } - return SCM_BOOL_F; -} - - -SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank); - -SCM -scm_array_rank (ra) - SCM ra; -{ - if (SCM_IMP (ra)) - return SCM_INUM0; - switch (SCM_TYP7 (ra)) - { - default: - return SCM_INUM0; - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_cvect: - case scm_tc7_dvect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_svect: - return SCM_MAKINUM (1L); - case scm_tc7_smob: - if (SCM_ARRAYP (ra)) - return SCM_MAKINUM (SCM_ARRAY_NDIM (ra)); - return SCM_INUM0; - } -} - - -SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions); - -SCM -scm_array_dimensions (ra) - SCM ra; -{ - SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; - if (SCM_IMP (ra)) - return SCM_BOOL_F; - switch (SCM_TYP7 (ra)) - { - default: - return SCM_BOOL_F; - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_cvect: - case scm_tc7_dvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL); - case scm_tc7_smob: - if (!SCM_ARRAYP (ra)) - return SCM_BOOL_F; - k = SCM_ARRAY_NDIM (ra); - s = SCM_ARRAY_DIMS (ra); - while (k--) - res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) : - SCM_MAKINUM (1 + (s[k].ubnd)) - , res); - return res; - } -} - - -static char s_bad_ind[] = "Bad scm_array index"; - - -long -scm_aind (ra, args, what) - SCM ra; - SCM args; - char *what; -{ - SCM ind; - register long j; - register scm_sizet pos = SCM_ARRAY_BASE (ra); - register scm_sizet k = SCM_ARRAY_NDIM (ra); - scm_array_dim *s = SCM_ARRAY_DIMS (ra); - if (SCM_INUMP (args)) - { - SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); - return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); - } - while (k && SCM_NIMP (args)) - { - ind = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); - j = SCM_INUM (ind); - SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); - pos += (j - s->lbnd) * (s->inc); - k--; - s++; - } - SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA, - NULL); - return pos; -} - - - -SCM -scm_make_ra (ndim) - int ndim; -{ - SCM ra; - SCM_NEWCELL (ra); - SCM_DEFER_INTS; - SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)), - "array")); - SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array); - SCM_ARRAY_V (ra) = scm_nullvect; - SCM_ALLOW_INTS; - return ra; -} - -static char s_bad_spec[] = "Bad scm_array dimension"; -/* Increments will still need to be set. */ - - -SCM -scm_shap2ra (args, what) - SCM args; - char *what; -{ - scm_array_dim *s; - SCM ra, spec, sp; - int ndim = scm_ilength (args); - SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); - ra = scm_make_ra (ndim); - SCM_ARRAY_BASE (ra) = 0; - s = SCM_ARRAY_DIMS (ra); - for (; SCM_NIMP (args); s++, args = SCM_CDR (args)) - { - spec = SCM_CAR (args); - if (SCM_IMP (spec)) - - { - SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what); - s->lbnd = 0; - s->ubnd = SCM_INUM (spec) - 1; - s->inc = 1; - } - else - { - SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what); - s->lbnd = SCM_INUM (SCM_CAR (spec)); - sp = SCM_CDR (spec); - SCM_ASSERT (SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), - spec, s_bad_spec, what); - s->ubnd = SCM_INUM (SCM_CAR (sp)); - s->inc = 1; - } - } - return ra; -} - -SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array); - -SCM -scm_dimensions_to_uniform_array (dims, prot, fill) - SCM dims; - SCM prot; - SCM fill; -{ - scm_sizet k, vlen = 1; - long rlen = 1; - scm_array_dim *s; - SCM ra; - if (SCM_INUMP (dims)) - if (SCM_INUM (dims) < SCM_LENGTH_MAX) - { - SCM answer; - answer = scm_make_uve (SCM_INUM (dims), prot); - if (SCM_NNULLP (fill)) - { - SCM_ASSERT (1 == scm_ilength (fill), - scm_makfrom0str (s_dimensions_to_uniform_array), - SCM_WNA, NULL); - scm_array_fill_x (answer, SCM_CAR (fill)); - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) - scm_array_fill_x (answer, SCM_MAKINUM (0)); - else - scm_array_fill_x (answer, prot); - return answer; - } - else - dims = scm_cons (dims, SCM_EOL); - SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)), - dims, SCM_ARG1, s_dimensions_to_uniform_array); - ra = scm_shap2ra (dims, s_dimensions_to_uniform_array); - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); - s = SCM_ARRAY_DIMS (ra); - k = SCM_ARRAY_NDIM (ra); - while (k--) - { - s[k].inc = (rlen > 0 ? rlen : 0); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - vlen *= (s[k].ubnd - s[k].lbnd + 1); - } - if (rlen < SCM_LENGTH_MAX) - SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot); - else - { - scm_sizet bit; - switch (SCM_TYP7 (scm_make_uve (0L, prot))) - { - default: - bit = SCM_LONG_BIT; - break; - case scm_tc7_bvect: - bit = 1; - break; - case scm_tc7_string: - bit = SCM_CHAR_BIT; - break; - case scm_tc7_fvect: - bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_dvect: - bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_cvect: - bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - } - SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit; - rlen += SCM_ARRAY_BASE (ra); - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); - *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen; - } - if (SCM_NNULLP (fill)) - { - SCM_ASSERT (1 == scm_ilength (fill), - scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA, - NULL); - scm_array_fill_x (ra, SCM_CAR (fill)); - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) - scm_array_fill_x (ra, SCM_MAKINUM (0)); - else - scm_array_fill_x (ra, prot); - if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) - return SCM_ARRAY_V (ra); - return ra; -} - - -void -scm_ra_set_contp (ra) - SCM ra; -{ - scm_sizet k = SCM_ARRAY_NDIM (ra); - if (k) - { - long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; - while (k--) - { - if (inc != SCM_ARRAY_DIMS (ra)[k].inc) - { - SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS); - return; - } - inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); - } - } - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); -} - - -SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); - -SCM -scm_make_shared_array (oldra, mapfunc, dims) - SCM oldra; - SCM mapfunc; - SCM dims; -{ - SCM ra; - SCM inds, indptr; - SCM imap; - scm_sizet i, k; - long old_min, new_min, old_max, new_max; - scm_array_dim *s; - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array); - SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array); - ra = scm_shap2ra (dims, s_make_shared_array); - if (SCM_ARRAYP (oldra)) - { - SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra); - old_min = old_max = SCM_ARRAY_BASE (oldra); - s = SCM_ARRAY_DIMS (oldra); - k = SCM_ARRAY_NDIM (oldra); - while (k--) - { - if (s[k].inc > 0) - old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - } - else - { - SCM_ARRAY_V (ra) = oldra; - old_min = 0; - old_max = (long) SCM_LENGTH (oldra) - 1; - } - inds = SCM_EOL; - s = SCM_ARRAY_DIMS (ra); - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - { - inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds); - if (s[k].ubnd < s[k].lbnd) - { - if (1 == SCM_ARRAY_NDIM (ra)) - ra = scm_make_uve (0L, scm_array_prototype (ra)); - else - SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra)); - return ra; - } - } - imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL); - if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array); - else - { - if (SCM_NINUMP (imap)) - - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); - imap = SCM_CAR (imap); - } - i = SCM_INUM (imap); - } - SCM_ARRAY_BASE (ra) = new_min = new_max = i; - indptr = inds; - k = SCM_ARRAY_NDIM (ra); - while (k--) - { - if (s[k].ubnd > s[k].lbnd) - { - SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1)); - imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); - if (SCM_ARRAYP (oldra)) - - s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i; - else - { - if (SCM_NINUMP (imap)) - - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); - imap = SCM_CAR (imap); - } - s[k].inc = (long) SCM_INUM (imap) - i; - } - i += s[k].inc; - if (s[k].inc > 0) - new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - else - s[k].inc = new_max - new_min + 1; /* contiguous by default */ - indptr = SCM_CDR (indptr); - } - SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, - "mapping out of range", s_make_shared_array); - if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - { - if (1 == s->inc && 0 == s->lbnd - && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) - return SCM_ARRAY_V (ra); - if (s->ubnd < s->lbnd) - return scm_make_uve (0L, scm_array_prototype (ra)); - } - scm_ra_set_contp (ra); - return ra; -} - - -/* args are RA . DIMS */ -SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array); - -SCM -scm_transpose_array (args) - SCM args; -{ - SCM ra, res, vargs, *ve = &vargs; - scm_array_dim *s, *r; - int ndim, i, k; - SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array), - SCM_WNA, NULL); - ra = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array); - args = SCM_CDR (args); - switch (SCM_TYP7 (ra)) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array); - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); - SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, - s_transpose_array); - SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE, - s_transpose_array); - return ra; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - vargs = scm_vector (args); - SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); - ve = SCM_VELTS (vargs); - ndim = 0; - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - { - i = SCM_INUM (ve[k]); - SCM_ASSERT (SCM_INUMP (ve[k]) && i >= 0 && i < SCM_ARRAY_NDIM (ra), - ve[k], SCM_ARG2, s_transpose_array); - if (ndim < i) - ndim = i; - } - ndim++; - res = scm_make_ra (ndim); - SCM_ARRAY_V (res) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra); - for (k = ndim; k--;) - { - SCM_ARRAY_DIMS (res)[k].lbnd = 0; - SCM_ARRAY_DIMS (res)[k].ubnd = -1; - } - for (k = SCM_ARRAY_NDIM (ra); k--;) - { - i = SCM_INUM (ve[k]); - s = &(SCM_ARRAY_DIMS (ra)[k]); - r = &(SCM_ARRAY_DIMS (res)[i]); - if (r->ubnd < r->lbnd) - { - r->lbnd = s->lbnd; - r->ubnd = s->ubnd; - r->inc = s->inc; - ndim--; - } - else - { - if (r->ubnd > s->ubnd) - r->ubnd = s->ubnd; - if (r->lbnd < s->lbnd) - { - SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; - r->lbnd = s->lbnd; - } - r->inc += s->inc; - } - } - SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array); - scm_ra_set_contp (res); - return res; - } -} - -/* args are RA . AXES */ -SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array); - -SCM -scm_enclose_array (axes) - SCM axes; -{ - SCM axv, ra, res, ra_inr; - scm_array_dim vdim, *s = &vdim; - int ndim, j, k, ninr, noutr; - SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA, - NULL); - ra = SCM_CAR (axes); - axes = SCM_CDR (axes); - if (SCM_NULLP (axes)) - - axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); - ninr = scm_ilength (axes); - ra_inr = scm_make_ra (ninr); - SCM_ASRTGO (SCM_NIMP (ra), badarg1); - switch SCM_TYP7 - (ra) - { - default: - badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array); - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - s->lbnd = 0; - s->ubnd = SCM_LENGTH (ra) - 1; - s->inc = 1; - SCM_ARRAY_V (ra_inr) = ra; - SCM_ARRAY_BASE (ra_inr) = 0; - ndim = 1; - break; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg1); - s = SCM_ARRAY_DIMS (ra); - SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra); - ndim = SCM_ARRAY_NDIM (ra); - break; - } - noutr = ndim - ninr; - axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); - SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array), - SCM_WNA, NULL); - res = scm_make_ra (noutr); - SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); - SCM_ARRAY_V (res) = ra_inr; - for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) - { - SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array); - j = SCM_INUM (SCM_CAR (axes)); - SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; - SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; - SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - SCM_CHARS (axv)[j] = 1; - } - for (j = 0, k = 0; k < noutr; k++, j++) - { - while (SCM_CHARS (axv)[j]) - j++; - SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; - SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; - SCM_ARRAY_DIMS (res)[k].inc = s[j].inc; - } - scm_ra_set_contp (ra_inr); - scm_ra_set_contp (res); - return res; -} - - - -SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p); - -SCM -scm_array_in_bounds_p (args) - SCM args; -{ - SCM v, ind = SCM_EOL; - long pos = 0; - register scm_sizet k; - register long j; - scm_array_dim *s; - SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p), - SCM_WNA, NULL); - v = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - if (SCM_NIMP (args)) - - { - ind = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p); - pos = SCM_INUM (ind); - } -tail: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p)); - case scm_tc7_smob: - k = SCM_ARRAY_NDIM (v); - s = SCM_ARRAY_DIMS (v); - pos = SCM_ARRAY_BASE (v); - if (!k) - { - SCM_ASRTGO (SCM_NULLP (ind), wna); - ind = SCM_INUM0; - } - else - while (!0) - { - j = SCM_INUM (ind); - if (!(j >= (s->lbnd) && j <= (s->ubnd))) - { - SCM_ASRTGO (--k == scm_ilength (args), wna); - return SCM_BOOL_F; - } - pos += (j - s->lbnd) * (s->inc); - if (!(--k && SCM_NIMP (args))) - break; - ind = SCM_CAR (args); - args = SCM_CDR (args); - s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p); - } - SCM_ASRTGO (0 == k, wna); - v = SCM_ARRAY_V (v); - goto tail; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_vector: - SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); - return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F; - } -} - - -SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); -SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref); - -SCM -scm_uniform_vector_ref (v, args) - SCM v; - SCM args; -{ - long pos; - - if (SCM_IMP (v)) - { - SCM_ASRTGO (SCM_NULLP (args), badarg); - return v; - } - else if (SCM_ARRAYP (v)) - { - pos = scm_aind (v, args, s_uniform_vector_ref); - v = SCM_ARRAY_V (v); - } - else - { - if (SCM_NIMP (args)) - - { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref); - pos = SCM_INUM (SCM_CAR (args)); - SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); - } - else - { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref); - pos = SCM_INUM (args); - } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); - } - switch SCM_TYP7 - (v) - { - default: - if (SCM_NULLP (args)) - return v; - badarg: - scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); - abort (); - outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref)); - case scm_tc7_smob: - { /* enclosed */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } - case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) - return SCM_BOOL_T; - else - return SCM_BOOL_F; - case scm_tc7_string: - return SCM_MAKICHR (SCM_CHARS (v)[pos]); - case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else - case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); - case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); -# endif - - case scm_tc7_svect: - return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); -#ifdef LONGLONGS - case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); -#endif - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif - case scm_tc7_dvect: - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); - case scm_tc7_cvect: - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif - case scm_tc7_vector: - return SCM_VELTS (v)[pos]; - } -} - -/* Internal version of scm_uniform_vector_ref for uves that does no error checking and - tries to recycle conses. (Make *sure* you want them recycled.) */ - -SCM -scm_cvref (v, pos, last) - SCM v; - scm_sizet pos; - SCM last; -{ - switch SCM_TYP7 - (v) - { - default: - scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); - case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) - return SCM_BOOL_T; - else - return SCM_BOOL_F; - case scm_tc7_string: - return SCM_MAKICHR (SCM_CHARS (v)[pos]); - case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else - case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); - case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); -# endif - case scm_tc7_svect: - return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); -#ifdef LONGLONGS - case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) - { - SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; - return last; - } - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif - case scm_tc7_dvect: -#ifdef SCM_SINGLES - if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) -#else - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) -#endif - { - SCM_REAL (last) = ((double *) SCM_CDR (v))[pos]; - return last; - } - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); - case scm_tc7_cvect: - if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) - { - SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; - SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; - return last; - } - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif - case scm_tc7_vector: - return SCM_VELTS (v)[pos]; - case scm_tc7_smob: - { /* enclosed scm_array */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } - } -} - -SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); -SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x); - -SCM -scm_array_set_x (v, obj, args) - SCM v; - SCM obj; - SCM args; -{ - long pos; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - if (SCM_ARRAYP (v)) - { - pos = scm_aind (v, args, s_array_set_x); - v = SCM_ARRAY_V (v); - } - else - { - if (SCM_NIMP (args)) - { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x); - pos = SCM_INUM (SCM_CAR (args)); - SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); - } - else - { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x); - pos = SCM_INUM (args); - } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); - } - switch (SCM_TYP7 (v)) - { - default: badarg1: - scm_wta (v, (char *) SCM_ARG1, s_array_set_x); - abort (); - outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x)); - case scm_tc7_smob: /* enclosed */ - goto badarg1; - case scm_tc7_bvect: - if (SCM_BOOL_F == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); - else if (SCM_BOOL_T == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x); - break; - case scm_tc7_string: - SCM_ASRTGO (SCM_ICHRP (obj), badarg3); - SCM_CHARS (v)[pos] = SCM_ICHR (obj); - break; - case scm_tc7_byvect: - if (SCM_ICHRP (obj)) - obj = SCM_MAKINUM (SCM_ICHR (obj)); - SCM_ASRTGO (SCM_INUMP (obj), badarg3); - ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); - break; -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3); - case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; -# else - case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break; - case scm_tc7_ivect: - SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break; -# endif - break; - - case scm_tc7_svect: - SCM_ASRTGO (SCM_INUMP (obj), badarg3); - ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x); - break; -#endif - - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); - ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj); - break; -#endif - case scm_tc7_dvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); - ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj); - break; - case scm_tc7_cvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3); - ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); - ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; - break; -#endif - case scm_tc7_vector: - SCM_VELTS (v)[pos] = obj; - break; - } - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents); - -SCM -scm_array_contents (ra, strict) - SCM ra; - SCM strict; -{ - SCM sra; - if (SCM_IMP (ra)) - return SCM_BOOL_F; - switch SCM_TYP7 - (ra) - { - default: - return SCM_BOOL_F; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return ra; - case scm_tc7_smob: - { - scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1; - if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra)) - return SCM_BOOL_F; - for (k = 0; k < ndim; k++) - len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - if (!SCM_UNBNDP (strict)) - { - if SCM_ARRAY_BASE - (ra) return SCM_BOOL_F; - if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc)) - return SCM_BOOL_F; - if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) - { - if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) || - SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) - return SCM_BOOL_F; - } - } - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) - return SCM_ARRAY_V (ra); - sra = scm_make_ra (1); - SCM_ARRAY_DIMS (sra)->lbnd = 0; - SCM_ARRAY_DIMS (sra)->ubnd = len - 1; - SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra); - SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1); - return sra; - } - } -} - - -SCM -scm_ra2contig (ra, copy) - SCM ra; - int copy; -{ - SCM ret; - long inc = 1; - scm_sizet k, len = 1; - for (k = SCM_ARRAY_NDIM (ra); k--;) - len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - k = SCM_ARRAY_NDIM (ra); - if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc))) - { - if (scm_tc7_bvect != SCM_TYP7 (ra)) - return ra; - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) && - 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) - return ra; - } - ret = scm_make_ra (k); - SCM_ARRAY_BASE (ret) = 0; - while (k--) - { - SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd; - SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd; - SCM_ARRAY_DIMS (ret)[k].inc = inc; - inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - } - SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra)); - if (copy) - scm_array_copy_x (ra, ret); - return ret; -} - - - -SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x); - -SCM -scm_uniform_array_read_x (ra, port) - SCM ra; - SCM port; -{ - SCM cra = SCM_UNDEFINED, v = ra; - long sz, len, ans; - long start = 0; - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, - s_uniform_array_read_x); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - - len = SCM_LENGTH (v); -loop: - switch SCM_TYP7 (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - cra = scm_ra2contig (ra, 0); - start = SCM_ARRAY_BASE (cra); - len = SCM_ARRAY_DIMS (cra)->inc * - (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); - v = SCM_ARRAY_V (cra); - goto loop; - case scm_tc7_string: - case scm_tc7_byvect: - sz = sizeof (char); - break; - case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif - } - - /* An ungetc before an fread will not work on some systems if setbuf(0). - do #define NOSETBUF in scmfig.h to fix this. */ - if (SCM_CRDYP (port)) - { /* UGGH!!! */ - ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port)); - SCM_CLRDY (port); /* Clear ungetted char */ - } - - SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, - (scm_sizet) sz, (scm_sizet) len, - (FILE *)SCM_STREAM (port))); - - if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; - - if (v != ra && cra != ra) - scm_array_copy_x (cra, ra); - - return SCM_MAKINUM (ans); -} - -SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write); - -SCM -scm_uniform_array_write (v, port) - SCM v; - SCM port; -{ - long sz, len, ans; - long start = 0; - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - len = SCM_LENGTH (v); -loop: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - v = scm_ra2contig (v, 1); - start = SCM_ARRAY_BASE (v); - len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1); - v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_byvect: - case scm_tc7_string: - sz = sizeof (char); - break; - case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif - } - SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); - if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; - return SCM_MAKINUM (ans); -} - - -static char cnt_tab[16] = -{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; - -SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count); - -SCM -scm_bit_count (item, seq) - SCM item; - SCM seq; -{ - long i; - register unsigned long cnt = 0, w; - SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count); - switch SCM_TYP7 - (seq) - { - default: - scm_wta (seq, (char *) SCM_ARG2, s_bit_count); - case scm_tc7_bvect: - if (0 == SCM_LENGTH (seq)) - return SCM_INUM0; - i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; - w = SCM_VELTS (seq)[i]; - if (SCM_FALSEP (item)) - w = ~w; - w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); - while (!0) - { - for (; w; w >>= 4) - cnt += cnt_tab[w & 0x0f]; - if (0 == i--) - return SCM_MAKINUM (cnt); - w = SCM_VELTS (seq)[i]; - if (SCM_FALSEP (item)) - w = ~w; - } - } -} - - -SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position); - -SCM -scm_bit_position (item, v, k) - SCM item; - SCM v; - SCM k; -{ - long i, lenw, xbits, pos = SCM_INUM (k); - register unsigned long w; - SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position); - SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, s_bit_position); - if (pos == SCM_LENGTH (v)) - return SCM_BOOL_F; - switch SCM_TYP7 - (v) - { - default: - scm_wta (v, (char *) SCM_ARG2, s_bit_position); - case scm_tc7_bvect: - if (0 == SCM_LENGTH (v)) - return SCM_MAKINUM (-1L); - lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ - i = pos / SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; - if (SCM_FALSEP (item)) - w = ~w; - xbits = (pos % SCM_LONG_BIT); - pos -= xbits; - w = ((w >> xbits) << xbits); - xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT; - while (!0) - { - if (w && (i == lenw)) - w = ((w << xbits) >> xbits); - if (w) - while (w) - switch (w & 0x0f) - { - default: - return SCM_MAKINUM (pos); - case 2: - case 6: - case 10: - case 14: - return SCM_MAKINUM (pos + 1); - case 4: - case 12: - return SCM_MAKINUM (pos + 2); - case 8: - return SCM_MAKINUM (pos + 3); - case 0: - pos += 4; - w >>= 4; - } - if (++i > lenw) - break; - pos += SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; - if (SCM_FALSEP (item)) - w = ~w; - } - return SCM_BOOL_F; - } -} - - -SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x); - -SCM -scm_bit_set_star_x (v, kv, obj) - SCM v; - SCM kv; - SCM obj; -{ - register long i, k, vlen; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - SCM_ASRTGO (SCM_NIMP (kv), badarg2); - switch SCM_TYP7 - (kv) - { - default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x); - case scm_tc7_uvect: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_BOOL_F == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); - SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); - } - else if (SCM_BOOL_T == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); - SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); - } - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x); - } - break; - case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); - if (SCM_BOOL_F == obj) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); - else if (SCM_BOOL_T == obj) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k]; - else - goto badarg3; - break; - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star); - -SCM -scm_bit_count_star (v, kv, obj) - SCM v; - SCM kv; - SCM obj; -{ - register long i, vlen, count = 0; - register unsigned long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - SCM_ASRTGO (SCM_NIMP (kv), badarg2); - switch SCM_TYP7 - (kv) - { - default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star); - case scm_tc7_uvect: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_BOOL_F == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); - if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) - count++; - } - else if (SCM_BOOL_T == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); - if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) - count++; - } - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star); - } - break; - case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); - if (0 == SCM_LENGTH (v)) - return SCM_INUM0; - SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); - obj = (SCM_BOOL_T == obj); - i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); - k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); - while (!0) - { - for (; k; k >>= 4) - count += cnt_tab[k & 0x0f]; - if (0 == i--) - return SCM_MAKINUM (count); - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); - } - } - return SCM_MAKINUM (count); -} - - -SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x); - -SCM -scm_bit_invert_x (v) - SCM v; -{ - register long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_bvect: - for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x); - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); - -SCM -scm_string_upcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_upcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); - } - return v; -} - -SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); - -SCM -scm_string_downcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_downcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); - } - return v; -} - - - -SCM -scm_istr2bve (str, len) - char *str; - long len; -{ - SCM v = scm_make_uve (len, SCM_BOOL_T); - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - register long k; - register long j; - for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) - { - data[k] = 0L; - j = len - k * SCM_LONG_BIT; - if (j > SCM_LONG_BIT) - j = SCM_LONG_BIT; - for (mask = 1L; j--; mask <<= 1) - switch (*str++) - { - case '0': - break; - case '1': - data[k] |= mask; - break; - default: - return SCM_BOOL_F; - } - } - return v; -} - - - -static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k)); - -static SCM -ra2l (ra, base, k) - SCM ra; - scm_sizet base; - scm_sizet k; -{ - register SCM res = SCM_EOL; - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_sizet i; - if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) - return SCM_EOL; - i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; - if (k < SCM_ARRAY_NDIM (ra) - 1) - { - do - { - i -= inc; - res = scm_cons (ra2l (ra, i, k + 1), res); - } - while (i != base); - } - else - do - { - i -= inc; - res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res); - } - while (i != base); - return res; -} - - -SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list); - -SCM -scm_array_to_list (v) - SCM v; -{ - SCM res = SCM_EOL; - register long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - return ra2l (v, SCM_ARRAY_BASE (v), 0); - case scm_tc7_vector: - return scm_vector_to_list (v); - case scm_tc7_string: - return scm_string_to_list (v); - case scm_tc7_bvect: - { - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) - for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1) - res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); - for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) - res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); - return res; - } -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *data = (long *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (SCM_MAKINUM (data[k]), res); - return res; - } -# else - case scm_tc7_uvect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ulong2num(data[k]), res); - return res; - } - case scm_tc7_ivect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long2num(data[k]), res); - return res; - } -# endif - case scm_tc7_svect: { - short *data; - data = (short *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(SCM_MAKINUM (data[k]), res); - return res; - } -#ifdef LONGLONGS - case scm_tc7_llvect: { - long_long *data; - data = (long_long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long_long2num(data[k]), res); - return res; - } -#endif - - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *data = (float *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makflo (data[k]), res); - return res; - } -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - { - double *data = (double *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k], 0.0), res); - return res; - } - case scm_tc7_cvect: - { - double (*data)[2] = (double (*)[2]) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); - return res; - } -#endif /*SCM_FLOATS*/ - } -} - - -static char s_bad_ralst[] = "Bad scm_array contents scm_list"; - -static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k)); - -SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array); - -SCM -scm_list_to_uniform_array (ndim, prot, lst) - SCM ndim; - SCM prot; - SCM lst; -{ - SCM shp = SCM_EOL; - SCM row = lst; - SCM ra; - scm_sizet k; - long n; - SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array); - k = SCM_INUM (ndim); - while (k--) - { - n = scm_ilength (row); - SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array); - shp = scm_cons (SCM_MAKINUM (n), shp); - if (SCM_NIMP (row)) - row = SCM_CAR (row); - } - ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL); - if (SCM_NULLP (shp)) - - { - SCM_ASRTGO (1 == scm_ilength (lst), badlst); - scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL); - return ra; - } - if (!SCM_ARRAYP (ra)) - { - for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst)) - scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); - return ra; - } - if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) - return ra; - else - badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array); - return SCM_BOOL_F; -} - -static int -l2ra (lst, ra, base, k) - SCM lst; - SCM ra; - scm_sizet base; - scm_sizet k; -{ - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); - int ok = 1; - if (n <= 0) - return (SCM_EOL == lst); - if (k < SCM_ARRAY_NDIM (ra) - 1) - { - while (n--) - { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return 0; - ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1); - base += inc; - lst = SCM_CDR (lst); - } - if (SCM_NNULLP (lst)) - return 0; - } - else - { - while (n--) - { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return 0; - ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base)); - base += inc; - lst = SCM_CDR (lst); - } - if (SCM_NNULLP (lst)) - return 0; - } - return ok; -} - - -static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate)); - -static void -rapr1 (ra, j, k, port, pstate) - SCM ra; - scm_sizet j; - scm_sizet k; - SCM port; - scm_print_state *pstate; -{ - long inc = 1; - long n = SCM_LENGTH (ra); - int enclosed = 0; -tail: - switch SCM_TYP7 - (ra) - { - case scm_tc7_smob: - if (enclosed++) - { - SCM_ARRAY_BASE (ra) = j; - if (n-- > 0) - scm_iprin1 (ra, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_ARRAY_BASE (ra) = j; - scm_iprin1 (ra, port, pstate); - } - break; - } - if (k + 1 < SCM_ARRAY_NDIM (ra)) - { - long i; - inc = SCM_ARRAY_DIMS (ra)[k].inc; - for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) - { - scm_gen_putc ('(', port); - rapr1 (ra, j, k + 1, port, pstate); - scm_gen_puts (scm_regular_string, ") ", port); - j += inc; - } - if (i == SCM_ARRAY_DIMS (ra)[k].ubnd) - { /* could be zero size. */ - scm_gen_putc ('(', port); - rapr1 (ra, j, k + 1, port, pstate); - scm_gen_putc (')', port); - } - break; - } - if SCM_ARRAY_NDIM - (ra) - { /* Could be zero-dimensional */ - inc = SCM_ARRAY_DIMS (ra)[k].inc; - n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); - } - else - n = 1; - ra = SCM_ARRAY_V (ra); - goto tail; - default: - if (n-- > 0) - scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); - } - break; - case scm_tc7_string: - if (n-- > 0) - scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate); - if (SCM_WRITINGP (pstate)) - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate); - } - else - for (j += inc; n-- > 0; j += inc) - scm_gen_putc (SCM_CHARS (ra)[j], port); - break; - case scm_tc7_byvect: - if (n-- > 0) - scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); - } - break; - - case scm_tc7_uvect: - case scm_tc7_ivect: - if (n-- > 0) - scm_intprint (SCM_VELTS (ra)[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (SCM_VELTS (ra)[j], 10, port); - } - break; - - case scm_tc7_svect: - if (n-- > 0) - scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); - } - break; - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - if (n-- > 0) - { - SCM z = scm_makflo (1.0); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - } - } - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - if (n-- > 0) - { - SCM z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - } - } - break; - case scm_tc7_cvect: - if (n-- > 0) - { - SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]); - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); - } - } - break; -#endif /*SCM_FLOATS*/ - } -} - - - -int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - SCM v = exp; - scm_sizet base = 0; - scm_gen_putc ('#', port); -tail: - switch SCM_TYP7 - (v) - { - case scm_tc7_smob: - { - long ndim = SCM_ARRAY_NDIM (v); - base = SCM_ARRAY_BASE (v); - v = SCM_ARRAY_V (v); - if (SCM_ARRAYP (v)) - - { - scm_gen_puts (scm_regular_string, "<enclosed-array ", port); - rapr1 (exp, base, 0, port, pstate); - scm_gen_putc ('>', port); - return 1; - } - else - { - scm_intprint (ndim, 10, port); - goto tail; - } - } - case scm_tc7_bvect: - if (exp == v) - { /* a uve, not an scm_array */ - register long i, j, w; - scm_gen_putc ('*', port); - for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) - { - w = SCM_VELTS (exp)[i]; - for (j = SCM_LONG_BIT; j; j--) - { - scm_gen_putc (w & 1 ? '1' : '0', port); - w >>= 1; - } - } - j = SCM_LENGTH (exp) % SCM_LONG_BIT; - if (j) - { - w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; - for (; j; j--) - { - scm_gen_putc (w & 1 ? '1' : '0', port); - w >>= 1; - } - } - return 1; - } - else - scm_gen_putc ('b', port); - break; - case scm_tc7_string: - scm_gen_putc ('a', port); - break; - case scm_tc7_byvect: - scm_gen_puts (scm_regular_string, "bytes", port); - break; - case scm_tc7_uvect: - scm_gen_putc ('u', port); - break; - case scm_tc7_ivect: - scm_gen_putc ('e', port); - break; - case scm_tc7_svect: - scm_gen_puts (scm_regular_string, "short", port); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - scm_gen_puts (scm_regular_string, "long_long", port); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - scm_gen_putc ('s', port); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - scm_gen_putc ('i', port); - break; - case scm_tc7_cvect: - scm_gen_putc ('c', port); - break; -#endif /*SCM_FLOATS*/ - } - scm_gen_putc ('(', port); - rapr1 (exp, base, 0, port, pstate); - scm_gen_putc (')', port); - return 1; -} - -SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); - -SCM -scm_array_prototype (ra) - SCM ra; -{ - int enclosed = 0; - SCM_ASRTGO (SCM_NIMP (ra), badarg); -loop: - switch SCM_TYP7 - (ra) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - if (enclosed++) - return SCM_UNSPECIFIED; - ra = SCM_ARRAY_V (ra); - goto loop; - case scm_tc7_vector: - return SCM_EOL; - case scm_tc7_bvect: - return SCM_BOOL_T; - case scm_tc7_string: - return SCM_MAKICHR ('a'); - case scm_tc7_byvect: - return SCM_MAKICHR ('\0'); - case scm_tc7_uvect: - return SCM_MAKINUM (1L); - case scm_tc7_ivect: - return SCM_MAKINUM (-1L); - case scm_tc7_svect: - return SCM_CDR (scm_intern ("s", 1)); -#ifdef LONGLONGS - case scm_tc7_llvect: - return SCM_CDR (scm_intern ("l", 1)); -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - return scm_makflo (1.0); -#endif - case scm_tc7_dvect: - return scm_makdbl (1.0 / 3.0, 0.0); - case scm_tc7_cvect: - return scm_makdbl (0.0, 1.0); -#endif - } -} - - -static SCM markra SCM_P ((SCM ptr)); - -static SCM -markra (ptr) - SCM ptr; -{ - if SCM_GC8MARKP - (ptr) return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_ARRAY_V (ptr); -} - - -static scm_sizet freera SCM_P ((SCM ptr)); - -static scm_sizet -freera (ptr) - SCM ptr; -{ - scm_must_free (SCM_CHARS (ptr)); - return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); -} - -static scm_smobfuns rasmob = -{markra, freera, scm_raprin1, scm_array_equal_p}; - - -/* This must be done after scm_init_scl() */ - -void -scm_init_unif () -{ -#include "unif.x" - scm_tc16_array = scm_newsmob (&rasmob); - scm_add_feature ("array"); -} - -#else /* ARRAYS */ - - -int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - return 0; -} - - -SCM -scm_istr2bve (str, len) - char *str; - long len; -{ - return SCM_BOOL_F; -} - -void -scm_init_unif () -{ - scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); -} - -#endif /* ARRAYS */ diff --git a/libguile/unif.h b/libguile/unif.h deleted file mode 100644 index 45aef3fe2..000000000 --- a/libguile/unif.h +++ /dev/null @@ -1,114 +0,0 @@ -/* classes: h_files */ - -#ifndef UNIFH -#define UNIFH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -typedef struct scm_array -{ - SCM v; - scm_sizet base; -} scm_array; - -typedef struct scm_array_dim -{ - long lbnd; - long ubnd; - long inc; -} scm_array_dim; - - -extern long scm_tc16_array; -#define SCM_ARRAYP(a) (scm_tc16_array==SCM_TYP16(a)) -#define SCM_ARRAY_V(a) (((scm_array *)SCM_CDR(a))->v) -#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CAR(x)>>17)) -#define SCM_ARRAY_CONTIGUOUS 0x10000 -#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)SCM_CAR(x)) -#define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)(SCM_CHARS(a)+sizeof(scm_array))) - -#define SCM_HUGE_LENGTH(x) (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x)) - - - -extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len)); -extern SCM scm_makflo SCM_P ((float x)); -extern SCM scm_make_uve SCM_P ((long k, SCM prot)); -extern SCM scm_uniform_vector_length SCM_P ((SCM v)); -extern SCM scm_array_p SCM_P ((SCM v, SCM prot)); -extern SCM scm_array_rank SCM_P ((SCM ra)); -extern SCM scm_array_dimensions SCM_P ((SCM ra)); -extern long scm_aind SCM_P ((SCM ra, SCM args, char *what)); -extern SCM scm_make_ra SCM_P ((int ndim)); -extern SCM scm_shap2ra SCM_P ((SCM args, char *what)); -extern SCM scm_dimensions_to_uniform_array SCM_P ((SCM dims, SCM prot, SCM fill)); -extern void scm_ra_set_contp SCM_P ((SCM ra)); -extern SCM scm_make_shared_array SCM_P ((SCM oldra, SCM mapfunc, SCM dims)); -extern SCM scm_transpose_array SCM_P ((SCM args)); -extern SCM scm_enclose_array SCM_P ((SCM axes)); -extern SCM scm_array_in_bounds_p SCM_P ((SCM args)); -extern SCM scm_uniform_vector_ref SCM_P ((SCM v, SCM args)); -extern SCM scm_cvref SCM_P ((SCM v, scm_sizet pos, SCM last)); -extern SCM scm_array_set_x SCM_P ((SCM v, SCM obj, SCM args)); -extern SCM scm_array_contents SCM_P ((SCM ra, SCM strict)); -extern SCM scm_ra2contig SCM_P ((SCM ra, int copy)); -extern SCM scm_uniform_array_read_x SCM_P ((SCM ra, SCM port)); -extern SCM scm_uniform_array_write SCM_P ((SCM v, SCM port)); -extern SCM scm_bit_count SCM_P ((SCM item, SCM seq)); -extern SCM scm_bit_position SCM_P ((SCM item, SCM v, SCM k)); -extern SCM scm_bit_set_star_x SCM_P ((SCM v, SCM kv, SCM obj)); -extern SCM scm_bit_count_star SCM_P ((SCM v, SCM kv, SCM obj)); -extern SCM scm_bit_invert_x SCM_P ((SCM v)); -extern SCM scm_string_upcase_x SCM_P ((SCM v)); -extern SCM scm_string_downcase_x SCM_P ((SCM v)); -extern SCM scm_istr2bve SCM_P ((char *str, long len)); -extern SCM scm_array_to_list SCM_P ((SCM v)); -extern SCM scm_list_to_uniform_array SCM_P ((SCM ndim, SCM prot, SCM lst)); -extern int scm_raprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_array_prototype SCM_P ((SCM ra)); -extern void scm_init_unif SCM_P ((void)); - -#endif /* UNIFH */ diff --git a/libguile/variable.c b/libguile/variable.c deleted file mode 100644 index 692219c0a..000000000 --- a/libguile/variable.c +++ /dev/null @@ -1,249 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "variable.h" - - -static scm_sizet free_var SCM_P ((SCM obj)); - -static scm_sizet -free_var (obj) - SCM obj; -{ - return 0; -} - - - -static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prin_var (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<variable ", port); - scm_intprint(exp, 16, port); - { - SCM val_cell; - val_cell = SCM_CDR(exp); - if (SCM_CAR (val_cell) != SCM_UNDEFINED) - { - scm_gen_puts (scm_regular_string, " name: ", port); - scm_iprin1 (SCM_CAR (val_cell), port, pstate); - } - scm_gen_puts (scm_regular_string, " binding: ", port); - scm_iprin1 (SCM_CDR (val_cell), port, pstate); - } - scm_gen_putc('>', port); - return 1; -} - - -static SCM scm_markvar SCM_P ((SCM ptr)); - -static SCM -scm_markvar (ptr) - SCM ptr; -{ - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_CDR (ptr); -} - -int scm_tc16_variable; -static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0}; - - -static SCM anonymous_variable_sym; - - -static SCM make_vcell_variable SCM_P ((SCM vcell)); - -static SCM -make_vcell_variable (vcell) - SCM vcell; -{ - SCM answer; - SCM_NEWCELL(answer); - SCM_REDEFER_INTS; - SCM_SETCAR (answer, scm_tc16_variable); - SCM_SETCDR (answer, vcell); - SCM_REALLOW_INTS; - return answer; -} - -SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable); - -SCM -scm_make_variable (init, name_hint) - SCM init; - SCM name_hint; -{ - SCM val_cell; - - if (name_hint == SCM_UNDEFINED) - name_hint = anonymous_variable_sym; - - SCM_NEWCELL(val_cell); - SCM_DEFER_INTS; - SCM_SETCAR (val_cell, name_hint); - SCM_SETCDR (val_cell, init); - SCM_ALLOW_INTS; - return make_vcell_variable (val_cell); -} - - -SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable); - -SCM -scm_make_undefined_variable (name_hint) - SCM name_hint; -{ - SCM vcell; - - if (name_hint == SCM_UNDEFINED) - name_hint = anonymous_variable_sym; - - SCM_NEWCELL (vcell); - SCM_DEFER_INTS; - SCM_SETCAR (vcell, name_hint); - SCM_SETCDR (vcell, SCM_UNDEFINED); - SCM_ALLOW_INTS; - return make_vcell_variable (vcell); -} - - -SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p); - -SCM -scm_variable_p (obj) - SCM obj; -{ - return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref); - -SCM -scm_variable_ref (var) - SCM var; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref); - return SCM_CDR (SCM_CDR (var)); -} - - - -SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x); - -SCM -scm_variable_set_x (var, val) - SCM var; - SCM val; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x); - SCM_SETCDR (SCM_CDR (var), val); - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable); - -SCM -scm_builtin_variable (name) - SCM name; -{ - SCM vcell; - SCM var_slot; - - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable); - vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T); - if (vcell == SCM_BOOL_F) - return SCM_BOOL_F; - - scm_intern_symbol (scm_symhash_vars, name); - var_slot = scm_sym2ovcell (name, scm_symhash_vars); - - SCM_DEFER_INTS; - if ( SCM_IMP (SCM_CDR (var_slot)) - || (SCM_VARVCELL (var_slot) != vcell)) - SCM_SETCDR (var_slot, make_vcell_variable (vcell)); - SCM_ALLOW_INTS; - - return SCM_CDR (var_slot); -} - - -SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p); - -SCM -scm_variable_bound_p (var) - SCM var; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p); - return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))) - ? SCM_BOOL_F - : SCM_BOOL_T); -} - - - - -void -scm_init_variable () -{ - scm_tc16_variable = scm_newsmob (&variable_smob); - anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED)); -#include "variable.x" -} - diff --git a/libguile/variable.h b/libguile/variable.h deleted file mode 100644 index 9bced2936..000000000 --- a/libguile/variable.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef VARIABLEH -#define VARIABLEH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - - -/* Variables - */ -extern int scm_tc16_variable; - -#define SCM_VARVCELL(V) SCM_CDR(V) -#define SCM_VARIABLEP(X) (scm_tc16_variable == SCM_CAR(X)) -#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) -#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) - - - -extern SCM scm_make_variable SCM_P ((SCM init, SCM name_hint)); -extern SCM scm_make_undefined_variable SCM_P ((SCM name_hint)); -extern SCM scm_variable_p SCM_P ((SCM obj)); -extern SCM scm_variable_ref SCM_P ((SCM var)); -extern SCM scm_variable_set_x SCM_P ((SCM var, SCM val)); -extern SCM scm_builtin_variable SCM_P ((SCM name)); -extern SCM scm_variable_bound_p SCM_P ((SCM var)); -extern void scm_init_variable SCM_P ((void)); - -#endif /* VARIABLEH */ diff --git a/libguile/vectors.c b/libguile/vectors.c deleted file mode 100644 index 4484bf841..000000000 --- a/libguile/vectors.c +++ /dev/null @@ -1,271 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" - -#include "vectors.h" - - - -SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p); - -SCM -scm_vector_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length); - -SCM -scm_vector_length(v) - SCM v; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_length); - return SCM_MAKINUM(SCM_LENGTH(v)); -} - -SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); -SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector); - -SCM -scm_vector(l) - SCM l; -{ - SCM res; - register SCM *data; - long i = scm_ilength(l); - SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector); - res = scm_make_vector(SCM_MAKINUM(i), SCM_UNSPECIFIED, SCM_UNDEFINED); - data = SCM_VELTS(res); - for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l)) - *data++ = SCM_CAR(l); - return res; -} - -SCM_PROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref); - -SCM -scm_vector_ref(v, k) - SCM v; - SCM k; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_ref); - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_ref); - SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_ref); - return SCM_VELTS(v)[((long) SCM_INUM(k))]; -} - - -SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x); - -SCM -scm_vector_set_x(v, k, obj) - SCM v; - SCM k; - SCM obj; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x); - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x); - SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x); - SCM_VELTS(v)[((long) SCM_INUM(k))] = obj; - return obj; -} - - -SCM_PROC(s_make_vector, "make-vector", 1, 2, 0, scm_make_vector); - -SCM -scm_make_vector(k, fill, multip) - SCM k; - SCM fill; - SCM multip; -{ - SCM v; - int multi; - register long i; - register long j; - register SCM *velts; - - SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector); - if (SCM_UNBNDP(fill)) - fill = SCM_UNSPECIFIED; - multi = !(SCM_UNBNDP(multip) || SCM_FALSEP(multip)); - i = SCM_INUM(k); - SCM_NEWCELL(v); - SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector)); - SCM_SETLENGTH(v, i, scm_tc7_vector); - velts = SCM_VELTS(v); - j = 0; - if (multi) - { - while ((fill != SCM_EOL) && (j < i)) - { - (velts)[j++] = SCM_CAR (fill); - fill = SCM_CDR (fill); - } - } - while(--i >= j) (velts)[i] = fill; - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list); - -SCM -scm_vector_to_list(v) - SCM v; -{ - SCM res = SCM_EOL; - long i; - SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list); - data = SCM_VELTS(v); - for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); - return res; -} - - -SCM_PROC(s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x); - -SCM -scm_vector_fill_x(v, fill_x) - SCM v; - SCM fill_x; -{ - register long i; - register SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x); - data = SCM_VELTS(v); - for(i = SCM_LENGTH(v)-1;i >= 0;i--) data[i] = fill_x; - return SCM_UNSPECIFIED; -} - - - -SCM -scm_vector_equal_p(x, y) - SCM x; - SCM y; -{ - long i; - for(i = SCM_LENGTH(x)-1;i >= 0;i--) - if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i]))) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - - -SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x); - -SCM -scm_vector_move_left_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; -{ - long i; - long j; - long e; - - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x); - i = SCM_INUM (start1); - j = SCM_INUM (start2); - e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x); - while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++]; - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x); - -SCM -scm_vector_move_right_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; -{ - long i; - long j; - long e; - - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x); - i = SCM_INUM (start1); - j = SCM_INUM (start2); - e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_right_x); - while (i<e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_vectors () -{ -#include "vectors.x" -} - diff --git a/libguile/vectors.h b/libguile/vectors.h deleted file mode 100644 index 5b98afbcc..000000000 --- a/libguile/vectors.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef VECTORSH -#define VECTORSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -#define SCM_VECTORP(x) (SCM_TYP7S(x)==scm_tc7_vector) -#define SCM_NVECTORP(x) (!SCM_VECTORP(x)) -#define SCM_VELTS(x) ((SCM *)SCM_CDR(x)) -#define SCM_SETVELTS SCM_SETCDR - - - -extern SCM scm_vector_p SCM_P ((SCM x)); -extern SCM scm_vector_length SCM_P ((SCM v)); -extern SCM scm_vector SCM_P ((SCM l)); -extern SCM scm_vector_ref SCM_P ((SCM v, SCM k)); -extern SCM scm_vector_set_x SCM_P ((SCM v, SCM k, SCM obj)); -extern SCM scm_make_vector SCM_P ((SCM k, SCM fill, SCM multi)); -extern SCM scm_vector_to_list SCM_P ((SCM v)); -extern SCM scm_vector_fill_x SCM_P ((SCM v, SCM fill_x)); -extern SCM scm_vector_equal_p SCM_P ((SCM x, SCM y)); -extern SCM scm_vector_move_left_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM - vec2, SCM start2)); -extern SCM scm_vector_move_right_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM - vec2, SCM start2)); -extern void scm_init_vectors SCM_P ((void)); - -#endif /* VECTORSH */ diff --git a/libguile/version.c b/libguile/version.c deleted file mode 100644 index 889b08efc..000000000 --- a/libguile/version.c +++ /dev/null @@ -1,85 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "_scm.h" - -#include "version.h" - - -/* Return a Scheme string containing Guile's major version number. */ - -SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version); - -SCM -scm_major_version () -{ - return scm_makfrom0str (GUILE_MAJOR_VERSION); -} - -/* Return a Scheme string containing Guile's minor version number. */ - -SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version); - -SCM -scm_minor_version () -{ - return scm_makfrom0str (GUILE_MINOR_VERSION); -} - -/* Return a Scheme string containing Guile's complete version. */ - -SCM_PROC(s_version, "version", 0, 0, 0, scm_version); - -SCM -scm_version () -{ - return scm_makfrom0str (GUILE_VERSION); -} - - - - -void -scm_init_version () -{ -#include "version.x" -} diff --git a/libguile/version.h b/libguile/version.h deleted file mode 100644 index ff48cf231..000000000 --- a/libguile/version.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef VERSIONH -#define VERSIONH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_major_version SCM_P ((void)); -extern SCM scm_minor_version SCM_P ((void)); -extern SCM scm_version SCM_P ((void)); -extern void scm_init_version SCM_P ((void)); - -#endif /* VERSIONH */ diff --git a/libguile/vports.c b/libguile/vports.c deleted file mode 100644 index 89e398e98..000000000 --- a/libguile/vports.c +++ /dev/null @@ -1,226 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eval.h" -#include "chars.h" -#include "fports.h" - -#include "vports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -/* {Ports - soft ports} - * - */ - - - -static int prinsfpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinsfpt (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (exp, port, "soft"); - return !0; -} - -/* sfputc sfwrite sfputs sfclose - * are called within a SCM_SYSCALL. - * - * So we need to set errno to 0 before returning. sfflush - * may be called within a SCM_SYSCALL. So we need to set errno to 0 - * before returning. - */ - - -static int sfputc SCM_P ((int c, SCM p)); - -static int -sfputc (c, p) - int c; - SCM p; -{ - scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull); - errno = 0; - return c; -} - - -static scm_sizet sfwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p)); - -static scm_sizet -sfwrite (str, siz, num, p) - char *str; - scm_sizet siz; - scm_sizet num; - SCM p; -{ - SCM sstr; - sstr = scm_makfromstr (str, siz * num, 0); - scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull); - errno = 0; - return num; -} - - -static int sfputs SCM_P ((char *s, SCM p)); - -static int -sfputs (s, p) - char *s; - SCM p; -{ - sfwrite (s, 1, strlen (s), p); - return 0; -} - - -static int sfflush SCM_P ((SCM stream)); - -static int -sfflush (stream) - SCM stream; -{ - SCM f = SCM_VELTS (stream)[2]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; -} - - -static int sfgetc SCM_P ((SCM p)); - -static int -sfgetc (p) - SCM p; -{ - SCM ans; - ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); - errno = 0; - if (SCM_FALSEP (ans) || SCM_EOF_VAL == ans) - return EOF; - SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "getc"); - return SCM_ICHR (ans); -} - - -static int sfclose SCM_P ((SCM p)); - -static int -sfclose (p) - SCM p; -{ - SCM f = SCM_VELTS (p)[4]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; -} - - - -SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port); - -SCM -scm_make_soft_port (pv, modes) - SCM pv; - SCM modes; -{ - struct scm_port_table * pt; - SCM z; - SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_make_soft_port); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes))); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, pv); - SCM_ALLOW_INTS; - return z; -} - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -scm_ptobfuns scm_sfptob = -{ - scm_markstream, - noop0, - prinsfpt, - 0, - sfputc, - sfputs, - sfwrite, - sfflush, - sfgetc, - sfclose -}; - - - -void -scm_init_vports () -{ -#include "vports.x" -} - diff --git a/libguile/vports.h b/libguile/vports.h deleted file mode 100644 index 27b14a3d6..000000000 --- a/libguile/vports.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef VPORTSH -#define VPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern scm_ptobfuns scm_sfptob; - - - - - - -extern SCM scm_make_soft_port SCM_P ((SCM pv, SCM modes)); -extern void scm_init_vports SCM_P ((void)); - -#endif /* VPORTSH */ diff --git a/libguile/weaks.c b/libguile/weaks.c deleted file mode 100644 index cb2912970..000000000 --- a/libguile/weaks.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, Free Software Foundation gives permission - * for additional uses of the text contained in its release of this library. - * - * The exception is that, if you link this library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking this library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by - * Free Software Foundation as part of this library. If you copy - * code from other releases distributed under the terms of the GPL into a copy of - * this library, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from such code. - * - * If you write modifications of your own for this library, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" - -#include "weaks.h" - - - -/* {Weak Vectors} - */ - - -SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector); - -SCM -scm_make_weak_vector (k, fill) - SCM k; - SCM fill; -{ - SCM v; - v = scm_make_vector (scm_sum (k, SCM_MAKINUM (1)), fill, SCM_UNDEFINED); - SCM_DEFER_INTS; - SCM_SETLENGTH(v, SCM_INUM (k), scm_tc7_wvect); - SCM_VELTS(v)[0] = (SCM)0; - SCM_SETVELTS(v, SCM_VELTS(v) + 1); - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector); -SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); - -SCM -scm_weak_vector (l) - SCM l; -{ - SCM res; - register SCM *data; - long i; - - i = scm_ilength (l); - SCM_ASSERT (i >= 0, l, SCM_ARG1, s_weak_vector); - res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); - data = SCM_VELTS (res); - for (; - i && SCM_NIMP (l) && SCM_CONSP (l); - --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); - return res; -} - - -SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p); - -SCM -scm_weak_vector_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - - - -SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table); - -SCM -scm_make_weak_key_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 1; - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table); - -SCM -scm_make_weak_value_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 2; - SCM_ALLOW_INTS; - return v; -} - - - -SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table); - -SCM -scm_make_doubly_weak_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 3; - SCM_ALLOW_INTS; - return v; -} - -SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p); - -SCM -scm_weak_key_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p); - -SCM -scm_weak_value_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p); - -SCM -scm_doubly_weak_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - -void -scm_init_weaks () -{ -#include "weaks.x" -} - diff --git a/libguile/weaks.h b/libguile/weaks.h deleted file mode 100644 index 8a6eb467d..000000000 --- a/libguile/weaks.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef WEAKSH -#define WEAKSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -#define SCM_WVECTP(x) (SCM_TYP7(x)==scm_tc7_wvect) -#define SCM_IS_WHVEC(X) (SCM_VELTS(X)[-1] == 1) -#define SCM_IS_WHVEC_V(X) (SCM_VELTS(X)[-1] == 2) -#define SCM_IS_WHVEC_B(X) (SCM_VELTS(X)[-1] == 3) -#define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1]) - - - -extern SCM scm_make_weak_vector SCM_P ((SCM k, SCM fill)); -extern SCM scm_weak_vector SCM_P ((SCM l)); -extern SCM scm_weak_vector_p SCM_P ((SCM x)); -extern SCM scm_make_weak_key_hash_table SCM_P ((SCM k)); -extern SCM scm_make_weak_value_hash_table SCM_P ((SCM k)); -extern SCM scm_make_doubly_weak_hash_table SCM_P ((SCM k)); -extern SCM scm_weak_key_hash_table_p SCM_P ((SCM x)); -extern SCM scm_weak_value_hash_table_p SCM_P ((SCM x)); -extern SCM scm_doubly_weak_hash_table_p SCM_P ((SCM x)); -extern void scm_init_weaks SCM_P ((void)); - -#endif /* WEAKSH */ |