diff options
| -rw-r--r-- | ANNOUNCE | 218 | ||||
| -rw-r--r-- | COPYING | 339 | ||||
| -rw-r--r-- | ChangeLog | 3029 | ||||
| -rw-r--r-- | Iedline.scm | 103 | ||||
| -rw-r--r-- | Init.scm | 854 | ||||
| -rw-r--r-- | Link.scm | 284 | ||||
| -rw-r--r-- | Makefile | 384 | ||||
| -rw-r--r-- | Makefile.in | 462 | ||||
| -rw-r--r-- | QUICKREF | 201 | ||||
| -rw-r--r-- | README | 384 | ||||
| -rw-r--r-- | README.unix | 182 | ||||
| -rw-r--r-- | Transcen.scm | 133 | ||||
| -rw-r--r-- | acconfig-1.5.h | 22 | ||||
| -rw-r--r-- | bench.scm | 55 | ||||
| -rwxr-xr-x | build.bat | 1 | ||||
| -rwxr-xr-x | build.scm | 1393 | ||||
| -rwxr-xr-x | configure | 849 | ||||
| -rw-r--r-- | configure.in | 33 | ||||
| -rw-r--r-- | continue.c | 255 | ||||
| -rw-r--r-- | continue.h | 178 | ||||
| -rw-r--r-- | crs.c | 412 | ||||
| -rw-r--r-- | dynl.c | 448 | ||||
| -rw-r--r-- | ecrt0.c | 614 | ||||
| -rw-r--r-- | edline.c | 94 | ||||
| -rw-r--r-- | eval.c | 1494 | ||||
| -rw-r--r-- | example.scm | 137 | ||||
| -rw-r--r-- | findexec.c | 145 | ||||
| -rw-r--r-- | gmalloc.c | 1638 | ||||
| -rw-r--r-- | gsubr.c | 138 | ||||
| -rw-r--r-- | install-sh | 238 | ||||
| -rw-r--r-- | ioext.c | 703 | ||||
| -rwxr-xr-x | mkinstalldirs | 35 | ||||
| -rw-r--r-- | patchlvl.h | 8 | ||||
| -rw-r--r-- | pi.c | 78 | ||||
| -rw-r--r-- | pi.scm | 165 | ||||
| -rw-r--r-- | posix.c | 408 | ||||
| -rw-r--r-- | pre-crt0.c | 9 | ||||
| -rw-r--r-- | r4rstest.scm | 1038 | ||||
| -rw-r--r-- | ramap.c | 1677 | ||||
| -rw-r--r-- | record.c | 349 | ||||
| -rw-r--r-- | repl.c | 1649 | ||||
| -rw-r--r-- | rgx.c | 661 | ||||
| -rw-r--r-- | rope.c | 335 | ||||
| -rw-r--r-- | sc2.c | 172 | ||||
| -rw-r--r-- | scl.c | 2393 | ||||
| -rw-r--r-- | scm.1 | 335 | ||||
| -rw-r--r-- | scm.c | 940 | ||||
| -rw-r--r-- | scm.doc | 330 | ||||
| -rw-r--r-- | scm.h | 817 | ||||
| -rw-r--r-- | scm.texi | 6911 | ||||
| -rw-r--r-- | scm4e3.scmconfig.patch | 60 | ||||
| -rw-r--r-- | scmconfig.h.in | 69 | ||||
| -rw-r--r-- | scmfig.h | 671 | ||||
| -rw-r--r-- | setjump.h | 122 | ||||
| -rw-r--r-- | setjump.mar | 38 | ||||
| -rw-r--r-- | setjump.s | 40 | ||||
| -rw-r--r-- | socket.c | 635 | ||||
| -rw-r--r-- | split.scm | 87 | ||||
| -rw-r--r-- | subr.c | 2009 | ||||
| -rw-r--r-- | sys.c | 1758 | ||||
| -rw-r--r-- | time.c | 389 | ||||
| -rw-r--r-- | unexec.c | 1238 | ||||
| -rw-r--r-- | unexelf.c | 908 | ||||
| -rw-r--r-- | unif.c | 2000 | ||||
| -rw-r--r-- | unix.c | 151 |
65 files changed, 43905 insertions, 0 deletions
diff --git a/ANNOUNCE b/ANNOUNCE new file mode 100644 index 0000000..0edea3c --- /dev/null +++ b/ANNOUNCE @@ -0,0 +1,218 @@ +This message announces the availability of Scheme release scm4e6. + +New in scm4e6 are: + + * bench.scm (benchmark): added. computes and display statistics + on "pi.scm" benchmark. + * Makefile (benchlit bench): targets added. Append stats to file + "BenchLog". + * scm.texi (Socket): added examples of chat servers and clients. + (Internet Addresses and Socket Names): enlarged from "Internet + Addresses". + * socket.c (l_connect): BUF0 was missing from mode bits set in + returned port. + * build.scm (build-params): Added compiler-options and + linker-options; added --batch-dialect and --script-name as aliases + for -h and -w. + * scmfig.h (HAVE_SELECT): Now defined for linux. + * sys.c (igc): fixed off-by-1 error for sizeof save_regs_gc_mark. + (gc_mark): fixed off-by-1 error for sizeof(CONTINUATION). These + seem to fix a very obscure GC bug. + * Init.scm (exec-self): Added. + * repl.c (init_repl): DUMP sets RESTART to EXEC-SELF. + * repl.c (tryload): Made tail-recursive so that dump, quit, exit, + etc. will work as the last expression in a loading file. + (scm_execpath): Split out from scm_unexec. + * unexec.c: All Updated from emacs-19.34 -- no changes necessary. + * gmalloc.c: + * pre-crt0.c: + * ecrt0.c: + * unexelf.c: fixes Linux (ELF) dump bug. + * build.scm (platform): linux renamed linux-aout. linux-elf fixed + and renamed linux. + (C-libraries): X11R6 moved library files on RedHat Linux. Linux + graphics library now has entry (doesn't default). + (compile-dll-c-files linux): + (make-dll-archive linux): Now converts from ".o" objects to ELF + ".so" form and "links" the usual libraries. + * Link.scm (usr:lib x:lib): dynamic linking fixed for (linux ELF) + dlopen. Libraries other than ".so" object not needed; eliminated + by usr:lib and x:lib returning #f. + * dynl.c (l_dyn_unlink): prints result of dlerror() on errors. + * eval.c (nconc2last): If CAUTIOUS is defined, checks that + APPLY's arglist and last element of arglist are LIST?s. + * sys.c (igc): symhash GC can now be disabled with + #define NO_SYM_GC. + * Init.scm (boot-tail): Added FSF --help and --version options. + Added --no-init-file as a synonym for -no-init-file. + * scm.texi (File-System Habitat): improved wording and added + examples. + * scm.texi (Top): Renamed sections. + * sys.c (mark_syms mark_sym_values): Split up mark_symhash() to + immunize against accidental pointers. + * repl.c (gc_ports_collected): added to instrument symbol GC. + * scm.texi (Debugging Scheme Code): Added section. + * eval.c (definedp): Changed from a memoizing macro to a `syntax'. + + From maximum entropy <entropy@zippy.bernstein.com>: + + * ioext.c, scmfig.h: support for SGI (tested with SGI IRIX 5.2/gcc) + * ioext.c (file_set_position): If a port is bidirectional + (e.g. a socket) it may be necessary on some systems to perform a + file positioning operation when switching between reading and + writing. This is required by ANSI C (ISO/IEC 9899:1990 + 7.9.5.3). Therefore, a file-set-position on a bidirectional + port should not signal an error if fseek generates an + ESPIPE -- the fseek operation actually "succeeded" in that it + reset the I/O direction flag for the FILE. + * repl.c (input_waiting): R4RS requires that "char-ready?" + return "#t" at end-of-file. The semantics for "ioctl(..., + FIONREAD, ...)" are such that it gives 0 on a socket that is + closed (on the other side of the connection). If the + system has select(), use that instead to get the correct + behavior. + * socket.c (l_listen): Treat sockets that have been "listened" + as input-ports. This allows polling for new connections + (e.g. with "char-ready?") instead of blocking in + "socket:accept". + * socket.c (l_accept): Fix type checking to agree with + previous patch. + + From Radey Shouman <shouman@zianet.com> + + * eval.c (unmemocar): The code in unmemocar to deal with ILOCs was + never being executed. + * sys.c (intern): fixed (new) symhash GC bug. + * sys.c (igc): Added calls to mark_symhash() and sweep_symhash(). + These GC unused symbols with a top-level value of UNDEFINED. + (mark_symhash): added. + (sweep_symhash): added. + + From Eric Hanchrow <erich@MICROSOFT.com> + + * scm.c (l_sleep): Ported to Windows NT (_WIN32) + * ioext.c: Ported to Windows NT (_WIN32) + + -=-=- + +Scm conforms to Revised^4 Report on the Algorithmic Language Scheme +and the IEEE P1178 specification. Scm is written in C and runs under +Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and +similar systems. ASCII and EBCDIC are supported. + +Documentation is included explaining the many Scheme Language +extensions in scm, the internal representations, and how to extend or +include SCM in other programs. Documentation is online at: + + http://ftp-swiss.ai.mit.edu/~jaffer/SCM.html + +SCM can be obtained via FTP (detailed instructions follow) from: + ftp-swiss.ai.mit.edu:pub/scm/scm4e6.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/scm4e6.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/scm4e6.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/scm4e6.tar.gz + +SLIB is a portable Scheme library which SCM uses: + ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2a6.tar.gz + +JACAL is a symbolic math system written in Scheme: + ftp-swiss.ai.mit.edu:pub/scm/jacal1a5.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/jacal1a5.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/jacal1a5.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/code/num/jacal1a5.tar.gz + +HOBBIT is a compiler for SCM code: + ftp-swiss.ai.mit.edu:pub/scm/hobbit4d.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/hobbit4d.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/hobbit4d.tar.gz + +SCMCONFIG contains additional files for the SCM distribution to build +SCM on Unix machines using GNU autoconf. + ftp-swiss.ai.mit.edu:pub/scm/scmconfig4e3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/scmconfig4e3.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/scmconfig4e3.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/scmconfig4e3.tar.gz + +SLIB-PSD is a portable debugger for Scheme (requires emacs editor): + ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz + +SLIB-SCHELOG is an embedding of Prolog in Scheme: + ftp-swiss.ai.mit.edu:pub/scm/slib-schelog.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/slib-schelog.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-schelog.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-schelog.tar.gz + +SMG-SCM is an SMG interface package which works with SCM on VMS. + ftp-swiss.ai.mit.edu:pub/scm/smg-scm2a1.zip + prep.ai.mit.edu:pub/gnu/jacal/smg-scm2a1.zip + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/smg-scm2a1.zip + ftp.maths.tcd.ie:pub/bosullvn/jacal/smg-scm2a1.zip +A VMS version of Unzip is available by anonymous FTP from + ftp.spc.edu:[ANONYMOUS.MACRO32]UNZIP.EXE. + +TURTLSCM is a turtle graphics package which works with SCM on MS-DOS +or X11 machines: + ftp-swiss.ai.mit.edu:pub/scm/turtlegr.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/turtlegr.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/turtlegr.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/turtlegr.tar.gz + +XSCM is a X windows interface package which works with SCM: + ftp-swiss.ai.mit.edu:pub/scm/xscm-2.01.tar.gz + prep.ai.mit.edu:pub/gnu/jacal/xscm-2.01.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/xscm-2.01.tar.gz + +MacSCM is a Macintosh applications building package which works with +SCM (similar to XSCM). + ftp-swiss.ai.mit.edu:pub/scm/macscm.tar.Z + ftp.maths.tcd.ie:pub/bosullvn/jacal/macscm.tar.Z + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/macscm.tar.gz + +WB is a disk based, sorted associative array (B-tree) library for SCM. +Using WB, large databases can be created and managed from SCM. + ftp-swiss.ai.mit.edu:pub/scm/wb1a2.tar.gz + ftp.maths.tcd.ie:pub/bosullvn/jacal/wb1a2.tar.gz + ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/wb1a2.tar.gz + +DLD is a C library package allowing SCM to dynamically load object +files on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation +(SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. + + prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz + -=-=- + + ftp ftp-swiss.ai.mit.edu (anonymous) + bin + cd pub/scm + get scm4e6.tar.gz + get slib2a6.tar.gz +or + ftp prep.ai.mit.edu (anonymous) + bin + cd pub/gnu/jacal + get scm4e6.tar.gz + get slib2a6.tar.gz + + `scm4e6.tar.gz' is a gzipped tar file of the C code distribution. + `slib2a6.tar.gz' is a gzipped tar file of a Scheme Library. + +Files in these directories with the ".gz" suffix are compressed with +patent-free gzip (no relation to zip). The program to uncompress them +is available from + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.tar + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.shar + prep.ai.mit.edu:pub/gnu/gzip-1.2.4.msdos.exe + +Remember to use binary mode when transferring the files. +Be sure to get and read the GNU General Public License (COPYING). +It is included in scm4e6.tar.gz. + +I sell IBM PC floppy disk sets with the source files, documentation, +and MS-DOS and i386 MS-DOS executables for $99.00. To order, send +e-mail to jaffer@ai.mit.edu. @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 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/ChangeLog b/ChangeLog new file mode 100644 index 0000000..e689bb5 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3029 @@ +Mon Nov 18 22:56:11 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * patchlvl.h (SCMVERSION): 4e6 released. + + * bench.scm (benchmark): added. computes and display statistics + on "pi.scm" benchmark. + + * Makefile (benchlit bench): targets added. Append stats to file + "BenchLog". + +Sun Nov 17 22:21:28 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * scm.texi (Socket): added examples of chat servers and clients. + (Internet Addresses and Socket Names): enlarged from "Internet + Addresses". + + * socket.c (l_connect): BUF0 was missing from mode bits set in + returned port. + +Sat Nov 16 22:02:39 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * build.scm (build-params): Added compiler-options and + linker-options; added --batch-dialect and --script-name as aliases + for -h and -w. + + * scmfig.h (HAVE_SELECT): Now defined for linux. + +Sat Nov 2 09:24:50 EST 1996 maximum entropy <entropy@zippy.bernstein.com> + + * ioext.c, scmfig.h: support for SGI (tested with SGI IRIX 5.2/gcc) + + * ioext.c (file_set_position): If a port is bidirectional + (e.g. a socket) it may be necessary on some systems to perform a + file positioning operation when switching between reading and + writing. This is required by ANSI C (ISO/IEC 9899:1990 + 7.9.5.3). Therefore, a file-set-position on a bidirectional + port should not signal an error if fseek generates an + ESPIPE -- the fseek operation actually "succeeded" in that it + reset the I/O direction flag for the FILE. + + * repl.c (input_waiting): R4RS requires that "char-ready?" + return "#t" at end-of-file. The semantics for "ioctl(..., + FIONREAD, ...)" are such that it gives 0 on a socket that is + closed (on the other side of the connection). If the + system has select(), use that instead to get the correct + behavior. + + * socket.c (l_listen): Treat sockets that have been "listened" + as input-ports. This allows polling for new connections + (e.g. with "char-ready?") instead of blocking in + "socket:accept". + + * socket.c (l_accept): Fix type checking to agree with + previous patch. + +Wed Nov 13 17:11:59 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * sys.c (igc): fixed off-by-1 error for sizeof save_regs_gc_mark. + (gc_mark): fixed off-by-1 error for sizeof(CONTINUATION). These + seem to fix a very obscure GC bug. + +Tue Oct 29 10:47:41 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * Init.scm (exec-self): Added. + + * repl.c (init_repl): DUMP sets RESTART to EXEC-SELF. + +Mon Oct 28 11:39:30 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * repl.c (tryload): Made tail-recursive so that dump, quit, exit, + etc. will work as the last expression in a loading file. + (scm_execpath): Split out from scm_unexec. + +Sun Oct 27 22:12:32 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com> + + * unexec.c: All Updated from emacs-19.34 -- no changes necessary. + * gmalloc.c: + * pre-crt0.c: + * ecrt0.c: + * unexelf.c: fixes Linux (ELF) dump bug. + +Mon Oct 21 21:49:20 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * build.scm (platform): linux renamed linux-aout. linux-elf fixed + and renamed linux. + (C-libraries): X11R6 moved library files on RedHat Linux. Linux + graphics library now has entry (doesn't default). + (compile-dll-c-files linux): + (make-dll-archive linux): Now converts from ".o" objects to ELF + ".so" form and "links" the usual libraries. + + * Link.scm (usr:lib x:lib): dynamic linking fixed for (linux ELF) + dlopen. Libraries other than ".so" object not needed; eliminated + by usr:lib and x:lib returning #f. + + * dynl.c (l_dyn_unlink): prints result of dlerror() on errors. + +Thu Oct 10 14:05:14 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * eval.c (nconc2last): If CAUTIOUS is defined, checks that + APPLY's arglist and last element of arglist are LIST?s. + +Sun Oct 6 16:40:54 1996 Radey Shouman <shouman@zianet.com> + + * eval.c (unmemocar): The code in unmemocar to deal with ILOCs was + never being executed. + +Fri Oct 4 13:57:35 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * sys.c (igc): symhash GC can now be disabled with + #define NO_SYM_GC. + +Wed Oct 2 20:51:07 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * Init.scm (boot-tail): Added FSF --help and --version options. + Added --no-init-file as a synonym for -no-init-file. + +Sun Sep 29 23:59:19 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * scm.texi (File-System Habitat): improved wording and added + examples. + +Thu Sep 26 22:23:32 1996 Radey Shouman <shouman@zianet.com> + + * sys.c (intern): fixed (new) symhash GC bug. + +Tue Sep 24 13:55:11 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * scm.texi (Top): Renamed sections. + + * sys.c (mark_syms mark_sym_values): Split up mark_symhash() to + immunize against accidental pointers. + +Sat Sep 14 22:53:46 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * repl.c (gc_ports_collected): added to instrument symbol GC. + +Sat Sep 14 15:35:29 1996 Radey Shouman <shouman@zianet.com> + + * sys.c (igc): Added calls to mark_symhash() and sweep_symhash(). + These GC unused symbols with a top-level value of UNDEFINED. + (mark_symhash): added. + (sweep_symhash): added. + +Wed Sep 11 21:18:05 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * scm.texi (Debugging Scheme Code): Added section. + +Sat Aug 31 14:05:24 1996 Eric Hanchrow <erich@MICROSOFT.com> + + * scm.c (l_sleep): Ported to Windows NT (_WIN32) + + * ioext.c: Ported to Windows NT (_WIN32) + +Sat Aug 31 13:18:34 1996 Aubrey Jaffer <jaffer@martigny.bertronics> + + * eval.c (definedp): Changed from a memoizing macro to a `syntax'. + +Sun Jul 21 01:06:44 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * Link.scm (link-named-scm): fixed to call "build.scm". + +Sat Jul 20 23:53:17 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scm.texi (Memoized Expressions): section added. + (Errors): section added. + +Wed Jul 17 17:40:01 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * r4rstest.scm: renamed from "test.scm". Now carries copyright + notice suitable for single file distribution. + +Fri May 17 23:37:16 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * findexec.c (dld_find_executable): names changed to keep up with + DLD changes. + +Sun May 12 21:43:14 1996 Radey Shouman <shouman@zianet.com> + + * unif.c (array_rank): Was returning 0 for bit-vectors. + (uve_fill): Fixed error report. + (lcount): + (position): Made to work with 1-d shared bit-arrays. + (aind): Added check for second argument, must be either + an INUM, NULL, or a pair. Without this, e.g. + (uniform-vector-set! <vector> 'x 0) + starts cdr'ing down the symbol ... + (array_inbp): Cleaned up to work with enclosed and huge arrays. + + * gsubr.c (gsubr_apply): Fixed error report. + + * scl.c (equal): Prevent fallthrough on last case, could cause + wierdness if cases are added later. + + * ramap.c (ra_matchp): Fixed to allow any 1-d array of zero size + to match a uniform vector, and to require all non-zero length + dimensions of two arrays to match even after a zero length + dimension. Now promotes 0-d arrays as well as scalars to match + first array shape. + (sc2array): Reshapes 0-d arrays as well as scalars. + Added check to make sure 2nd argument is really an array, + vector or uve. + (ramapc): Changed to allocate fewer array headers when arguments + are 1-d arrays. (Still allocates more than strictly necessary.) + (array_copy): Added check for scalar destination argument, since + ra_matchp() will now promote scalars to arrays. + +Sun May 12 00:52:51 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * build.scm (build): fixed HP-UX compile-dll-c-files. + + * findexec.c (dld_find_executable): ifdefed out stat() for hpux. + + * scm.c: New const declarations rejected by hp-ux cc; ifdefed out. + +Thu May 9 10:28:14 1996 Tim Pierce <twpierce@midway.uchicago.edu> + + * time.c sys.c findexec.c: string[s].h configuration for Solaris + 2.3 system using gcc 2.7.2. + +Tue Apr 9 19:46:21 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * sys.c (igc): stackbase argument added. Passing 0 disables stack + marking (used by dump). + + * build.scm (build link-c-program djgpp): + (build compile-c-files djgpp): Uses new batch:apply-chop-to-fit to + deal with MS-DOS line length restrictions. + +Sun Apr 7 23:15:36 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * repl.c (repl_driver): now supports unexec conditionally by + CAN_DUMP. + (scm_unexec): moved from dump.c. Now throws to top level to avoid + saving continuations. + + * dump.c: removed. Contents moved to repl.c. + + * continue.c (dynthrow): One instruction interrupt vulnerability + removed for machines with long ints. Others define SHORT_INT. + + * repl.c (repl_driver): Throws to top level now encoded by COOKIE + flags for non- SHORT_INT platforms. + +Sat Apr 6 14:29:47 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * unexec.c (A_TEXT_OFFSET A_TEXT_SEEK ADJUST_EXEC_HEADER NO_REMAP + TEXT_START HAVE_GETPAGESIZE SEGMENT_MASK): definitions moved from + scmfig.h. + + * gmalloc.c (HAVE_GETPAGESIZE): copied definition here so that + scm.h and scmfig.h won't be included for just one definition. + + * dump.c (scm_dump): reworked to use execpath as default second + argument. Removed "#include DUMP_CODE" abomination; using + suppress parameters in build.scm + + * build.scm (build C-libraries): added dump (unexec) and nostart + libraries to support dump. + (build compile-commands): Added support for dump + (build features): dump + + * scm.c (execpath): now a global which init_dump() also sets. + + * repl.c (repl_driver): added scm_evstr("(boot-tail)") call + after scm_ldfile(initpath) so command-line arguments can be + processed after "Init.scm" is loaded. + + * build.scm (build platform): added record for MS-DOS so defaults + don't cause errors when -p not specified. + +Mon Jan 9 15:43:36 1995 Patrick LECOANET <lecoanet%sid1@cenaath.cena.dgac.fr> + + * dump.c (dump): created. + + * pre-crt0.c crt0.c gmalloc.c unexec.c unexelf.c: adapted from + emacs (circa 1994). + +Fri Apr 5 00:16:59 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * ramap.c (ramapc ra2contig array_imap): Added +0L to cast first + argument to make_uve() to long. + +Thu Apr 4 00:47:09 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * ramap.c: removed #ifdef ARRAYS (over whole file). + +Wed Apr 3 10:14:18 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * Link.scm (compile-file): Now calls build.scm for compiling C. + + * hobbit.scm ("auxiliary functions" butlast ...): removed and + renamed gratuitous (and incompatible) duplications of + slib/comlist.scm. + +Mon Apr 1 08:56:09 1996 Johann Friedrich Heinrichmeyer <Fritz.Heinrichmeyer@fernuni-hagen.de> + + * sys.c (stack_check): sizeof(STACKITEM) was multiplied on wrong + side of inequality. + +Fri Mar 29 23:52:03 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * patchlvl.h (SCMVERSION): 4e4 + + * build.scm (build): microsoft-c-nt support added. + + * scm.c (l_raise): Disabled for WINDOWS_NT. + (scm_find_impl_file): fixed for getenv("SCM_INIT_PATH") case. + +Sun Mar 24 00:18:10 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * build.scm (build): fixed -tdll to not make archive or compile + all 'linkable files. + +Sun Mar 10 17:23:39 1996 Radey Shouman <shouman@ccwf.cc.utexas.edu> + + * ramap.c (sc2array): Added, converts a scalar to a shared array. + (ramapc): Uses sc2array to convert scalar arguments to arrays + for ARRAY-MAP! &c. + (ura_read, ura_write, ura_fill): Added. + (array_map): Added check for number of arguments when procedure + arg is a subr. Added cclo case. + + * unif.c (dims2ura): Fixed, it wasn't properly filling its result + sometimes. Added range check for size of conventional arrays. + (aind): Added range check when called as subr3. + (array_inbp): Returns #t if called with a scalar and no + index args -- APLish boundary case. + (cvref): Now recycles enclosed array refs. + (aset): Uses num2dbl for setting inexact array elts, so + e.g. (array-set! <inexact-array> 0 ...) works. + (array_contents): For strict option, wasn't returning an array + whenever the base was non-zero, now less restrictive. + (ra2contig): moved to ramap.c, as it calls ramapc(). To allow + dynamic linking of ramap.c. + (rafill): moved from ramap.c, to allow filling of arrays on + creation without needing ramap.c. + (uve_fill): Added, for filling uves / 1-d arrays without needing + ramap.c. + (uve_read, uve_write): (Re)added + (ura_read, ura_write): Moved to ramap.c, now call uve_[read write]. + (ra2l): uses cvref instead of aref, maybe faster and works for + enclosed arrays. + (init_unif): Added feature 'string-case, to prevent require + from nuking STRING-UPCASE!, STRING-DOWNCASE! + (encl_array): Added range check for dimension args. + + * rope.c (num2dbl): Added, analogous to num2dbl. + + * scmfig.h Eliminated redundant #ifdef + + * scl.c (makdbl) Rearranged so that it tests for out of range + double argument before assigning to float variable, this + avoids causing SIGFPE on my Linux box. + (equal): Fixed so that it doesn't need extern array_equal, + allowing ramap.c to be dynamically linkable. + + * scm.c Added documented variable *scm-version* + +Thu Mar 21 00:14:29 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * Link.scm (scm:object-suffix): Changed to ".so" when + 'sun-dl is PROVIDED?. + + * scmfig.h (getcwd): addition for scmconfig. + * findexec.c: minor change for scmconfig. + +Wed Mar 20 00:12:43 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * README (Making SCM with Think C 4.0 or 4.1): Instructions added + back in. + +Sun Mar 17 00:17:21 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * findexec.c (dld_find_executable): Added support for ~ and ~/ in + PATH environment variable. + +Sat Mar 16 10:38:15 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scm.c (scm_find_impl_file): Added generic_name argument to test + for cases where executable *doesn't* have its usual name. + (scm_sep_init_try): Added combined function to reduce length of + scm_find_impl_file. + (scm_try_path): Now tests for (and returns) 0. + + * build.scm (build): fixed assorted bugs. + +Tue Mar 12 12:48:28 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * 4e3: released. + * repl.c (read_token): ',' now delimits token. + +Mon Mar 4 23:19:50 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scm.texi (SLIB and require.scm): SLIB installation and + "require.scm" trampoline configuration method explained. + + * Init.scm (load:pre load:post): added to share code between + scm:load and scm:load-source. "require" is now loaded using the + regular calls; trying to maintain SCM initializing without SLIB is + too hard. + +Sun Mar 3 10:59:23 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * build.bat: Added for MS-DOS. + +Fri Mar 1 23:47:57 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scm.texi (Line Editing): html-linked readline and editline ftp + sites. + + * build.scm: Added support for edline. + +Wed Feb 28 23:39:55 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * build.scm (build:build): library field `supress-files' added. + Used for supressing "findexec.c" when DLD is present. + +Sun Feb 25 00:29:47 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * scm.c (scm_find_impl_file): Tries hard to find Init.scm in + implementation vicinity. + (scm_try_path scm_cat_path): used by scm_find_impl_file. + (main): Changed to use scm_find_impl_file() and free pathnames + before exit. + +Wed Feb 21 23:27:43 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * findexec.c (dld_find_executable): extracted from DLD for + general use. + +Tue Feb 20 00:08:29 1996 Jochen Schwarze <schwarze@isa.de> + + * Init.scm (*vicinity-suffix*): Now includes #\/ for MSDOS, + etc. (GCC support). + (library-vicinity): Now set from implementation-vicinity if + environment variable SCHEME_LIBRARY_PATH is not defined. + + * scm.c (SYSTNAME): not redefined with DJGPP (both MSDOS and + unix). + +Sun Feb 18 09:29:57 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * subr.c (divbigint): fixed sign bug for 0 return value. + +Sun Feb 18 00:29:43 1996 Per Bothner <bothner@cygnus.com> + + * gsubr.c (gsubr_apply): elided gratuitous make_vector call. + +Sat Feb 17 11:50:41 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * Init.scm (*features*): string-case added. + (string-upcase string-downcase string-capitalize): added. + + * unif.c (strcap): string-capitalize! + + * sys.c (sysintern): Now looks for (and uses) symbol already + created. This will eliminate order of linking and loading + dependencies. + +Tue Sep 26 20:37:25 1995 Aubrey Jaffer (jaffer@jacal) + + * scm.texi (Evaluation): Enlarged description to include type + folding. + (Cells): Split Node Cells into Header, Subr, Ptob, and Smob Cells. + +Fri Sep 22 22:31:13 1995 Aubrey Jaffer (jaffer@jacal) + + * scm.c scmfig.h (WINDOWS_NT): support added. But what flag does + Windows NT #define? + +Sun Sep 10 13:37:44 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.c (scm_stack_trace): Added Scheme call "stack-trace" to + print stack from exception handlers. + (everr): Now processes all exceptions before longjmping to + rootcont #ifdef CAUTIOUS. + + * Init.scm (user-interrupt): If stack-trace available, prints + stack-trace and enters breakpoint. + (break): Autoloaded. + +Mon Aug 7 12:52:15 1995 Aubrey Jaffer (jaffer@jacal) + + * scm.h (stacktrace): now a sys_protect. + + * subr.c (ilength): differentiated negative return codes; + non-terminating returns -1, not a list -2. + +Sat Aug 5 18:50:11 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.c (scm_print_stack): added. Called by def_err_response. + + * eval.c (ceval): SCM stacktrace variable maintained and saved + in CONT(cont)->other.stacktrace. Under CAUTIOUS flag, + checkargs1 label added to check special single argument calls. + +Wed Jul 26 23:26:21 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.c (char_readyp): Now looks for BUF0 flag to determine if + input_waiting() possible. + + * scm.c (init_scm run_scm main): BUF0 flag now set on cur_inp + to indicate whether CHAR-READY? will work. + +Wed Jul 19 13:25:01 1995 Shigenobu Kimura <skimu@komachi.phys.s.u-tokyo.ac.jp> + * dynl.c (l_dyn_main_call): Arguments to main (in DLD section) + were reveresed! Added hpux l_dyn_main_call. + +Sat Jul 8 22:23:03 1995 Aubrey Jaffer (jaffer@jacal) + + * Init.scm (scm:load): Internal define dependency problem fixed. + Variable *interactive* set for invocation without options. + + * scm.texi: Guile WWW and citation added. + + * subr.c: logical (2's complement) operations rewritten to now + work with bignums. Logical procedure names changed to conform + with Guile convention. + +Fri Jun 9 13:47:58 1995 Aubrey Jaffer (jaffer@jacal) + + * continue.c (stack_size): + (make_root_continuation): + (make_continuation): + (free_continuation): + (throw_to_continuation): moved from sys.c to make possible library + module. + + * continue.h: created from setjump.h + + * scm.texi (Compiling And Linking): Documented l_dyn_main_call. + (Type Conversions): added rope.c documentation. + (Callbacks): split from "Calling Scheme From C". + (Continuations): Rewritten to describe new "continue.c" + +Fri May 19 01:32:12 1995 Aubrey Jaffer (jaffer@jacal) + + * *.c: converted applicable uses of makfromstr with strlen to + makfrom0str. + + * rope.c: new + (scm_addr): added. + (num2long num2ulong num2ushort num2uchar ulong2num long2num): + moved from scl.c and elsewhere. + (makfromstrs makfrom0str makfromstr): moved from sys.c and posix.c + (must_free_argv): new + (scm_ldprog scm_ldfile scm_ldstr scm_evstr): moved from repl.c + (makargvfrmstrs): chopped out of i_execv in ioext.c. + makargvfrmstrs isn't really done correctly; it is GC leaky. + It should return a SMOB which can be GCed, but this makes this + C interface harder to use. + + * dynl.c (l_dyn_main_call): added procedure to call + dynamically linked procedure with string arguments converted + to argv and argc. Written only for DLD. Needs to be repeated + for other dynamic linking regimes. + +Tue Apr 25 10:24:42 1995 Aubrey Jaffer (jaffer@jacal) + + * subr.c (make_string): Was silently failing for illegal 2nd args! + +Sat Apr 15 23:18:47 1995 Aubrey Jaffer (jaffer@jacal) + + * Link.scm (catalog:add-link): When feature is already in catalog, + will only add new feature association to catalog if file exists. + +Sun Apr 9 22:59:46 1995 Aubrey Jaffer (jaffer@jacal) + + * repl.c (repl_driver): Now closes load port when ABORTing. + +Sat Apr 8 21:35:43 1995 Aubrey Jaffer (jaffer@jacal) + + From: Tom Lord <lord@cygnus.com> + * scm.texi: + Tcl Facilities:: Mutual calling between Tcl and Scheme. + Tk Facilities:: Accessing Tk from Scheme. + Gwish:: A Wish-like application of Guile. + System Calls:: Psst. Wanna write a manual section? + Gscsh:: Shell and systems programming features. + + From: chen@adi.com (Franklin Chen) + * scm.c (l_raise): uses raise() ifdef STDC_HEADERS, otherwise + kill(). + + From: Radey Shouman <shouman@ccwf.cc.utexas.edu> + * scl.c (istr2int): Fixed complaints of overflow on octal numbers + >= 2^BITSPERDIGIT. Patch should make this work for all radix 2 <= + radix <= 16. + (num2ulong): Makes it work for negative bignum argments, and + adds an overflow check. + + * ramap.c unif.c: There are several places in ramap.c, and + raprin1() in unif.c, where I had assumed that an ivect or uvect + elt would be representable no larger than an INUM. This patch + should fix these, also adding overflow checking for array + arithmetic on uvects and ivects. + + Also, fixes aref, which assumed that if its argument was a smob + that it was an array. Changes cvref to return a real number when + the imaginary part of an elt is 0. + +Sat Mar 25 20:37:48 1995 Aubrey Jaffer (jaffer@jacal) + + From: Don Bennett <dpb@netcom.com> + * rgx.c: rewritten and extended. The compile function now takes a + string of optional flags. New operations specific to the GNU + regex library is conditionalized with _GNU_SOURCE. + + From: Radey Shouman <shouman@ccwf.cc.utexas.edu> + * Iedline.scm ((make-edited-line-port)): + * edline.c (lreadline): Added Gnu `readline' input editing + (get ftp.sys.toronto.edu:/pub/rc/editline.shar). + + * unif.c (ra2contig): Fix a nasty bug ra2contig() (used for + UNIFORM-ARRAY-WRITE / READ!) that produced arrays with undersized + contents vectors. + + * eval.c (apply): Fix so that (APPLY <cclo> '()) works properly. + + * gsubr.c (make_gsubr): Give the arg number ASSERTion the right + sense. + (gsubr_apply): Add an ASSERTion to check for too many arguments. + (gsubr_apply): Take the address of the temporary vector, so as to + prevent its being optimized away and allowing gc of the vector. + (This happened with Cray cc in the MAP and FOR-EACH code; I'm no + longer able to find out if it would happen there.) + +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 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. + +Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal) + + * scm.texi (Overview): scm.1 converted to texinfo format and + incorporated. + +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. + +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) + + * scm.texi (Trouble Shooting): Section converted from README. + + * Init.scm (-d filename): option added which does: + (begin (require 'database-utilities) (open-database filename)) + + * 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. + +Tue Jan 3 15:09:36 1995 Aubrey Jaffer (jaffer@jacal) + + * scl.c (SYSTNAME): msdos changed to ms-dos. windows added. + archimedes changed to acorn. + + From: jon_seymour@vnet.ibm.com (jon seymour) + * scmfig.h: defined LACK_TIMES and STDC_HEADERS if __IBMC__ is + defined. + + * sys.c: #include <io.h> and #include <direct.h>. define ttyname() + macro. + + * scm.c: #include <io.h> and compile out execvp() call. + + * time.c: #include <sys/timeb.h> + + * makefile.os2: makefile for use with OS/2 toolkit nmake. + +Sun Jan 1 21:17:36 1995 Aubrey Jaffer (jaffer@jacal) + + * dynl.c Link.scm: names unified. Libraries for HP-UX fixed. + HP-UX dll suffix now ".sl". + + From: Shigenobu Kimura <skimu@komachi.phys.s.u-tokyo.ac.jp> * + dynl.c (fcall): Fixed dynamic linking on hp9000s700 (or 720) HP-UX + 9.01 or 9.03. + +Wed Dec 7 21:19:26 1994 Aubrey Jaffer (jaffer@jacal) + + * ioext.c (l_open_input_pipe, l_open_output_pipe): moved from + "Init.scm". + +Mon Dec 5 16:55:21 1994 Aubrey Jaffer (jaffer@jacal) + + * sys.c (i_setbuf0): added. + (open_file): `0' in mode string now controls the buffered-ness of + returned port. + + * Init.scm (slib:load-compiled): no longer silently fails if other + than the first argument does not link correctly. + + From: Robert Sanders <rsanders@hrothgar.mindspring.com> + * ioext.c (l_write_line): moved from "Init.scm". + +Sun Dec 4 21:47:08 1994 Aubrey Jaffer (jaffer@jacal) + + * sys.c (free_storage): lord@cygnus.com pointed out that candle + was being burnt from both ends. Loop fixed. Mallocs either + leaking or counted wrong. + +Sat Dec 3 22:32:59 1994 Aubrey Jaffer (jaffer@jacal) + + * code.doc: added description of compiled closures. + +Thu Nov 24 23:10:31 1994 Aubrey Jaffer (jaffer@jacal) + + * socket.c (l_socketpair): added. Both make-stream-socketpair and + make-stream-socket now take optional prototype argument. + +Tue Nov 22 00:16:05 1994 Aubrey Jaffer (jaffer@jacal) + + * ramap.c (ramapc and friends): moved from unif.c to get source + file sizes below 64k. + +Mon Nov 21 00:44:32 1994 Aubrey Jaffer (jaffer@jacal) + + * posix.c (l_pwinfo grinfo): made to work like network inquiry + procedures (no args steps through entries). + (l_setgr l_setpw l_uname): added. + + From: Radey Shouman <shouman@ccwf.cc.utexas.edu> + * gsubr.c (make_gsubr gubr_apply): allows arbitrary (< 11) + required, optional, and rest arguments to compiled functions. + +Sun Nov 20 11:59:18 1994 Aubrey Jaffer (jaffer@jacal) + + * socket.c MANUAL: most Scheme names for socket functions changed + for consistency. + * socket.c (socket:shutdown): added. I can't imagine what use + shutdown provides. SOCKETs can be closed like any other port. + Should socket:shutdown SOCKETs be closed? Does having shutdown + sockets cause file descriptors to be reused? Socket:shutdown will + be removed if no use is found for it. + (tc16_sknm): added to encapsulate information retrieved from + getpeername and getsockname. + (socket-name:family socket-name:port-number socket-name:address): + added to retrieve information from tc16_sknm. + (inet:string->address inet:address->string inet:network + inet:local-network-address inet:make-address): added. + (gethost sethostent getnet getnetent getproto setprotoent getserv + setservent): inquiry procedures added. + + * sys.c (makfromstrs(argc, argv)): added. converts C array of + strings to SCM list of strings. If argc < 0, a null terminated + array is assumed. + +Sat Nov 19 00:20:58 1994 Aubrey Jaffer (jaffer@jacal) + + * eval.c (l_proc_doc): added procedure-documentation. + +Fri Nov 18 23:34:35 1994 Aubrey Jaffer (jaffer@jacal) + + * build.scm (scm:build): Added. Replaces system specific + makefiles. + * ccnfigdb.scm: Database of system specific compile, link, and + archive procedures and library information. + +Thu Oct 27 12:57:02 1994 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 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 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. + +Mon Aug 29 11:36:46 1994 Radey Shouman <rshouman@hpcf.cc.utexas.edu> + + * 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 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 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 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 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 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 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 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 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 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 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 "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 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 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 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 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 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 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 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 soravi@Athena.MIT.EDU + + * makefile.emx: for OS/2 + +Sun Jan 24 18:46:32 1993 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 stevev@miser.uoregon.edu (Steve VanDevender): + + * config.h (INUM MAKINUM): shift optimization for TURBOC. + +Fri Jan 22 00:46:58 1993 hanche@ams.sunysb.edu (Harald Hanche-Olsen) + + * unif.c (uniform-vector?): added. + +Tue Jan 19 00:27:04 1993 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 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 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 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 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 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 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 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 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 "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. + + From: boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza) + * scl.c (eqv? memv assv): created if FLOATS is #defined. + +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 seperate 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. + + From: Yasuaki Honda, honda@csl.SONY.co.jp, + * README Init.scm subr.c scm.c repl.c scl.c: 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. + + * 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. + + From: jjc@jclark.com + * repl.c (repl_driver): now checks that s_response is non-NULL + before INTERNing. + +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 bevan@cs.man.ac.uk + + * subr.c scm.h (remainder): renamed to lremainder to avoid + conflict with math.h on SunOS4.1. + +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. + + From: jclark@bugs.specialix.co.uk.jjc + * sys.c (lreadr): 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/Iedline.scm b/Iedline.scm new file mode 100644 index 0000000..cbeb265 --- /dev/null +++ b/Iedline.scm @@ -0,0 +1,103 @@ +;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;; "Iedline.scm" Scheme interface to readline library +;; Author: Radey Shouman + +;; Change both current-input-port and current-output-port to +;; allow line editing of input. +;; All output goes through a soft port in order to detect prompt +;; lines, i.e. lines unterminated by a newline. + +(define (make-edited-line-port) + (let ((prompt "") + (outp (default-output-port)) + (inp (default-input-port)) + (strp (call-with-input-string "" identity))) + (make-soft-port + (vector (lambda (c) + (write-char c outp)) + (lambda (s) + (display s outp) + (or (zero? (string-length s)) + (eq? #\newline (string-ref s (- (string-length s) 1))) + (begin + (set! prompt (string-append "\r" s)) + (force-output outp)))) + (lambda () + (force-output outp)) + (lambda () + (let tail ((c (read-char strp))) + (if (char? c) c + (let ((str (read-edited-line prompt))) + (if (string? str) + (let ((n (string-length str))) + (add-history str) + (vector-set-length! str (+ 1 n)) + (string-set! str n #\newline) + (set! strp (call-with-input-string + str identity)) + (tail (read-char strp))) + str))))) + #f) + OPEN_BOTH))) + +(define line-editing + (let ((edit-port #f) + (oiport #f) + (ooport #f)) + (lambda arg + (define past edit-port) + (cond ((null? arg)) + ((and (car arg) (not edit-port)) + (set! edit-port (make-edited-line-port)) + (set! oiport (set-current-input-port edit-port)) + (set! ooport (set-current-output-port edit-port))) + (edit-port + (set-current-input-port oiport) + (set-current-output-port ooport) + (set! edit-port #f))) + past))) + +(and + (if (provided? 'unix) (isatty? (current-input-port)) #t) + (eq? (current-input-port) (default-input-port)) + (not (getenv "EMACS")) + (line-editing #t)) diff --git a/Init.scm b/Init.scm new file mode 100644 index 0000000..758c407 --- /dev/null +++ b/Init.scm @@ -0,0 +1,854 @@ +;; Copyright (C) 1991, 1992, 1993, 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. + +;;;; "Init.scm", Scheme initialization code for SCM. +;;; Author: Aubrey Jaffer. + +(define (scheme-implementation-type) 'SCM) +(define (scheme-implementation-version) "4e6") + +;;; Temporary hack for compatability with older versions. +(define software-type + (cond ((eq? 'msdos (software-type)) + (lambda () 'ms-dos)) + (else software-type))) + +;;; This definition of PROGRAM-VICINITY is a copy of the definition in +;;; SLIB/require.scm. It is used here to bootstrap +;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY. + +(define program-vicinity + (let ((*vicinity-suffix* + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((MACOS THINKC) '(#\:)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda () + (let loop ((i (- (string-length *load-pathname*) 1))) + (cond ((negative? i) "") + ((memv (string-ref *load-pathname* i) *vicinity-suffix*) + (substring *load-pathname* 0 (+ i 1))) + (else (loop (- i 1)))))))) + +(define in-vicinity string-append) + +;;; This is the vicinity where this file resides. +(define implementation-vicinity + (let ((vic (program-vicinity))) + (lambda () vic))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use +;;; (implementation-vicinity) as (library-vicinity). "require.scm", +;;; the first file loaded from (library-vicinity), can redirect it. + +(define library-vicinity + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path (lambda () library-path) + implementation-vicinity))) + +;;; Here for backward compatability +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +(set! *features* + (append '(getenv tmpnam abort transcript with-file + ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay eval dynamic-wind + multiarg-apply multiarg/and- logical defmacro + string-port source current-time) + *features*)) + +(define slib:exit quit) +(define (exec-self) + (require 'i/o-extensions) + (execv (execpath) (program-arguments))) + +(define (terms) + (list-file (in-vicinity (implementation-vicinity) "COPYING"))) + +(define (list-file file) + (call-with-input-file file + (lambda (inport) + (do ((c (read-char inport) (read-char inport))) + ((eof-object? c)) + (write-char c))))) + +(define (read:eval-feature exp) + (cond ((symbol? exp) + (or (memq exp *features*) (eq? exp (software-type)))) + ((and (pair? exp) (list? exp)) + (case (car exp) + ((not) (not (read:eval-feature (cadr exp)))) + ((or) (if (null? (cdr exp)) #f + (or (read:eval-feature (cadr exp)) + (read:eval-feature (cons 'or (cddr exp)))))) + ((and) (if (null? (cdr exp)) #t + (and (read:eval-feature (cadr exp)) + (read:eval-feature (cons 'and (cddr exp)))))) + (else (error "read:sharp+ invalid expression " exp)))))) + +(define (read:array digit port) + (define chr0 (char->integer #\0)) + (let ((rank (let readnum ((val (- (char->integer digit) chr0))) + (if (char-numeric? (peek-char port)) + (readnum (+ (* 10 val) + (- (char->integer (read-char port)) chr0))) + val))) + (prot (if (eq? #\( (peek-char port)) + '() + (let ((c (read-char port))) + (case c ((#\b) #t) + ((#\a) #\a) + ((#\u) 1) + ((#\e) -1) + ((#\s) 1.0) + ((#\i) 1/3) + ((#\c) 0+i) + (else (error "read:array unknown option " c))))))) + (if (eq? (peek-char port) #\() + (list->uniform-array rank prot (read port)) + (error "read:array list not found")))) + +(define (read:uniform-vector proto port) + (if (eq? #\( (peek-char port)) + (list->uniform-array 1 proto (read port)) + (error "read:uniform-vector list not found"))) + +(define (read:sharp c port) + (define (barf) + (error "unknown # object" c)) + (case c ((#\') (read port)) + ((#\+) (if (read:eval-feature (read port)) + (read port) + (begin (read port) (if #f #f)))) + ((#\-) (if (not (read:eval-feature (read port))) + (read port) + (begin (read port) (if #f #f)))) + ((#\b) (read:uniform-vector #t port)) + ((#\a) (read:uniform-vector #\a port)) + ((#\u) (read:uniform-vector 1 port)) + ((#\e) (read:uniform-vector -1 port)) + ((#\s) (read:uniform-vector 1.0 port)) + ((#\i) (read:uniform-vector 1/3 port)) + ((#\c) (read:uniform-vector 0+i port)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (read:array c port)) + ((#\!) (if (= 1 (line-number)) + (let skip () (if (eq? #\newline (peek-char port)) + (if #f #f) + (begin (read-char port) (skip)))) + (barf))) + (else (barf)))) + +(define type 'type) ;for /bin/sh hack. + +;;;; Here are some Revised^2 Scheme functions: +(define 1+ + (let ((+ +)) + (lambda (n) (+ n 1)))) +(define -1+ + (let ((+ +)) + (lambda (n) (+ n -1)))) +(define 1- -1+) +(define <? <) +(define <=? <=) +(define =? =) +(define >? >) +(define >=? >=) +(define t #t) +(define nil #f) +(define sequence begin) + +(set! apply + (let ((apply:nconc-to-last apply:nconc-to-last) + (@apply @apply)) + (lambda (fun . args) (@apply fun (apply:nconc-to-last args))))) +(define call-with-current-continuation + (let ((@call-with-current-continuation @call-with-current-continuation)) + (lambda (proc) (@call-with-current-continuation proc)))) + +;;; VMS does something strange when output is sent to both +;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT. +(case (software-type) ((VMS) (set-current-error-port (current-output-port)))) + +;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper +;;; mode to open files in. MS-DOS does carraige return - newline +;;; translation if not opened in `b' mode. + +(define OPEN_READ (case (software-type) + ((MS-DOS WINDOWS ATARIST) "rb") + (else "r"))) +(define OPEN_WRITE (case (software-type) + ((MS-DOS WINDOWS ATARIST) "wb") + (else "w"))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS ATARIST) "r+b") + (else "r+"))) +(define (_IONBF mode) (string-append mode "0")) + +(define could-not-open #f) + +(define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) +(define (open-output-file str) + (or (open-file str OPEN_WRITE) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-OUTPUT-FILE couldn't open file " str))) +(define (open-io-file str) (open-file str OPEN_BOTH)) + +(define close-input-port close-port) +(define close-output-port close-port) +(define close-io-port close-port) + +(define (call-with-input-file str proc) + (let* ((file (open-input-file str)) + (ans (proc file))) + (close-input-port file) + ans)) + +(define (call-with-output-file str proc) + (let* ((file (open-output-file str)) + (ans (proc file))) + (close-output-port file) + ans)) + +(define (with-input-from-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-input-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-output-to-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-output-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-error-to-port port thunk) + (let* ((swaports (lambda () (set! port (set-current-error-port port))))) + (dynamic-wind swaports thunk swaports))) + +(define (with-input-from-file file thunk) + (let* ((nport (open-input-file file)) + (ans (with-input-from-port nport thunk))) + (close-port nport) + ans)) + +(define (with-output-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-output-to-port nport thunk))) + (close-port nport) + ans)) + +(define (with-error-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-error-to-port nport thunk))) + (close-port nport) + ans)) + +(if (not (defined? force-output)) + (define (force-output . a) #f)) + +(define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (force-output cep) + (abort)) + +(define set-errno errno) +(define exit quit) + +(define (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (if port (begin (close-port port) #t) + #f))) + +(define difftime -) +(define offset-time +) + +(if (not (memq 'ed *features*)) + (begin + (define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "ed") + (map (lambda (s) (string-append " " s)) args)))) + (set! *features* (cons 'ed *features*)))) + +(if (not (defined? output-port-width)) + (define (output-port-width . arg) 80)) + +(if (not (defined? output-port-height)) + (define (output-port-height . arg) 24)) + +(if (not (defined? last-pair)) + (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) + +(define (has-suffix? str suffix) + (let ((sufl (string-length suffix)) + (sl (string-length str))) + (and (> sl sufl) + (string=? (substring str (- sl sufl) sl) suffix)))) + +(define (identity x) x) +(define slib:error error) +(define slib:tab #\tab) +(define slib:form-feed #\page) +(define slib:eval eval) + +;;; Load. +(define load:indent 0) +(define (load:pre file) + (define cep (current-error-port)) + (cond ((> (verbose) 1) + (display + (string-append ";" (make-string load:indent #\ ) "loading " file) + cep) + (set! load:indent (modulo (+ 2 load:indent) 16)) + (newline cep))) + (force-output cep)) + +(define (load:post filesuf) + (define cep (current-error-port)) + (errno 0) + (cond ((> (verbose) 1) + (set! load:indent (modulo (+ -2 load:indent) 16)) + (display (string-append ";" (make-string load:indent #\ ) + "done loading " filesuf) + cep) + (newline cep) + (force-output cep)))) + +(define (scm:load file . libs) + (define filesuf file) + (define hss (has-suffix? file (scheme-file-suffix))) + (load:pre file) + (or (and (defined? link:link) (not hss) + (or (apply link:link file libs) + (and link:able-suffix + (let ((fs (string-append file link:able-suffix))) + (cond ((not (file-exists? fs)) #f) + ((apply link:link fs libs) (set! filesuf fs) #t) + (else #f)))))) + (and (null? libs) (try-load file)) + ;;HERE is where the suffix gets specified + (and (not hss) + (begin (errno 0) ; clean up error from TRY-LOAD above + (set! filesuf (string-append file (scheme-file-suffix))) + (try-load filesuf))) + (and (procedure? could-not-open) (could-not-open) #f) + (let () (set! load:indent 0) + (error "LOAD couldn't find file " file))) + (load:post filesuf)) +(define load scm:load) +(define slib:load load) + +(define (scm:load-source file) + (define sfs (scheme-file-suffix)) + (define filesuf file) + (load:pre file) + (or (and (or (try-load file) + ;;HERE is where the suffix gets specified + (and (not (has-suffix? file sfs)) + (begin (set! filesuf (string-append file sfs)) + (try-load filesuf))))) + (and (procedure? could-not-open) (could-not-open) #f) + (error "LOAD couldn't find file " file)) + (load:post filesuf)) +(define slib:load-source scm:load-source) + +(load (in-vicinity (library-vicinity) "require")) + +;;; DO NOT MOVE! This has to be done after "require.scm" is loaded. +(define slib:load-source scm:load-source) +(define slib:load scm:load) + +(cond ((or (defined? dyn:link) + (defined? vms:dynamic-link-call) + (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms"))) + (load (in-vicinity (implementation-vicinity) "Link")))) + +(cond ((defined? link:link) + (define (slib:load-compiled . args) + (or (apply link:link args) + (error "Couldn't link files " args))) + (provide 'compiled))) + +(define (string-upcase str) (string-upcase! (string-copy str))) +(define (string-downcase str) (string-downcase! (string-copy str))) +(define (string-capitalize str) (string-capitalize! (string-copy str))) + +(define logical:logand logand) +(define logical:logior logior) +(define logical:logxor logxor) +(define logical:lognot lognot) +(define logical:ash ash) +(define logical:logcount logcount) +(define logical:integer-length integer-length) +(define logical:bit-extract bit-extract) +(define logical:integer-expt integer-expt) + +(define (logical:ipow-by-squaring x k acc proc) + (cond ((zero? k) acc) + ((= 1 k) (proc acc x)) + (else (logical:ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) + +;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): +(define *defmacros* '()) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define defmacro:transformer + (lambda (f) + (procedure->memoizing-macro + (lambda (exp env) + (copy-tree (apply f (cdr exp))))))) + +(define defmacro + (let ((defmacro-transformer + (lambda (name parms . body) + `(define ,name + (let ((transformer (lambda ,parms ,@body))) + (set! *defmacros* (acons ',name transformer *defmacros*)) + (defmacro:transformer transformer)))))) + (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*)) + (defmacro:transformer defmacro-transformer))) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "scm:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) + +(define (slib:eval-load <filename> evl) + (if (not (file-exists? <filename>)) + (set! <filename> (string-append <filename> (scheme-file-suffix)))) + (call-with-input-file <filename> + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* <filename>) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +(define (print . args) + (define result #f) + (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) + (newline) + result) + +;;; Autoloads for SLIB procedures. + +(define (tracef . args) (require 'trace) (apply tracef args)) +(define (trace:tracef . args) (require 'trace) (apply trace:tracef args)) +(define (trace-all . args) (require 'debug) (apply trace-all args)) +(define (pretty-print . args) (require 'pretty-print) + (apply pretty-print args)) + +;;; Macros. + +;;; Trace gets redefmacroed when tracef autoloads. +(defmacro trace x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x)))) +(defmacro break x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) x)))) + +(defmacro defvar (var val) + `(if (not (defined? ,var)) (define ,var ,val))) + +(cond + ((defined? stack-trace) + + #+breakpoint-error;; remove this line to enable breakpointing on errors + (define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + + (define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) (display "ERROR: user interrupt" cep) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + )) + +;;; ABS and MAGNITUDE can be the same. +(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) + (if (defined? usr:lib) + (if (usr:lib "m") + (load (in-vicinity (implementation-vicinity) "Transcen") + (usr:lib "m")) + (load (in-vicinity (implementation-vicinity) "Transcen"))) + (load (in-vicinity (implementation-vicinity) "Transcen" + (scheme-file-suffix)))) + (set! abs magnitude))) + +(if (defined? array?) + (begin + (define uniform-vector? array?) + (define make-uniform-vector dimensions->uniform-array) +; (define uniform-vector-ref array-ref) + (define (uniform-vector-set! u i o) + (uniform-vector-set1! u o i)) +; (define uniform-vector-fill! array-fill!) +; (define uniform-vector-read! uniform-array-read!) +; (define uniform-vector-write uniform-array-write) + + (define (make-array fill . args) + (dimensions->uniform-array args () fill)) + (define (make-uniform-array prot . args) + (dimensions->uniform-array args prot)) + (define (list->array ndim lst) + (list->uniform-array ndim '() lst)) + (define (list->uniform-vector prot lst) + (list->uniform-array 1 prot lst)) + (define (array-shape a) + (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) + (array-dimensions a))))) + +;;;; Initialize statically linked add-ons +(cond ((defined? scm_init_extensions) + (scm_init_extensions) + (set! scm_init_extensions #f))) + +;;; Use *argv* instead of (program-arguments), to allow option +;;; processing to be done on it. "ScmInit.scm" must +;;; (set! *argv* (program-arguments)) +;;; if it wants to alter the arguments which BOOT-TAIL processes. +(define *argv* #f) + +;;; This loads the user's initialization file, or files named in +;;; program arguments. + +(or + (eq? (software-type) 'THINKC) + (member "-no-init-file" (program-arguments)) + (member "--no-init-file" (program-arguments)) + (try-load + (in-vicinity + (let ((home (getenv "HOME"))) + (if home + (case (software-type) + ((UNIX COHERENT) + (if (char=? #\/ (string-ref home (+ -1 (string-length home)))) + home ;V7 unix has a / on HOME + (string-append home "/"))) + (else home)) + (user-vicinity))) + "ScmInit.scm")) + (errno 0)) + +(if (not (defined? *R4RS-macro*)) + (define *R4RS-macro* #f)) +(if (not (defined? *interactive*)) + (define *interactive* #f)) + +(define (boot-tail) + (cond ((not *argv*) (set! *argv* (program-arguments)) + (cond ((provided? 'getopt) (set! *optind* 1) + (set! *optarg* #f))))) + (cond + ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) + (require 'getopt) +;;; (else +;;; (define *optind* 1) +;;; (define getopt:opt #f) +;;; (define (getopt argc argv optstring) #f)) + + (let* ((simple-opts "muqvbis") + (arg-opts '("a kbytes" "no-init-file" "-no-init-file" + "-version" "-help" "p number" + "r feature" "f filename" "l filename" + "d filename" "c string" "e string" + "o filename")) + (opts (apply string-append ":" simple-opts + (map (lambda (o) + (string-append (string (string-ref o 0)) ":")) + arg-opts))) + (argc (length *argv*)) + (didsomething #f) + (moreopts #t) + (exe-name (symbol->string (scheme-implementation-type))) + (up-name (apply string (map char-upcase (string->list exe-name))))) + + (define (do-thunk thunk) + (if *interactive* + (thunk) + (let ((complete #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (thunk) + (set! complete #t)) + (lambda () (if (not complete) (quit #f))))))) + + (define (do-string-arg) + (require 'string-port) + (do-thunk + (lambda () + ((if *R4RS-macro* macro:eval eval) + (call-with-input-string + (string-append "(begin " *optarg* ")") + read)))) + (set! didsomething #t)) + + (define (do-load file) + (do-thunk + (lambda () + (cond (*R4RS-macro* (require 'macro) (macro:load file)) + (else (load file))))) + (set! didsomething #t)) + + (define (usage preopt opt postopt success?) + (define cep (if success? (current-output-port) (current-error-port))) + (define indent (make-string 6 #\ )) + (define i 3) + (cond ((char? opt) (set! opt (string opt))) + ;;((symbol? opt) (set! opt (symbol->string opt))) + ) + (display (string-append preopt opt postopt) cep) + (newline cep) + (display (string-append "Usage: " + exe-name + " [-a kbytes] [-" simple-opts "]") cep) + (for-each + (lambda (o) + (display (string-append " [-" o "]") cep) + (set! i (+ 1 i)) + (cond ((zero? (modulo i 4)) (newline cep) (display indent cep)))) + (cdr arg-opts)) + (display " [-- | -s | -] [file] [args...]" cep) (newline cep) + (if success? (display success? cep) (exit #f))) + + ;; -a int => ignore (handled by run_scm) + ;; -c str => (eval str) + ;; -e str => (eval str) + ;; -d str => (require 'database-utilities) (open-database str) + ;; -f str => (load str) + ;; -l str => (load str) + ;; -r str => (require str) + ;; -o str => (dump str) + ;; -p int => (verbose int) + ;; -m => (set! *R4RS-macro* #t) + ;; -u => (set! *R4RS-macro* #f) + ;; -v => (verbose 3) + ;; -q => (verbose 0) + ;; -i => (set! *interactive* #t) + ;; -b => (set! *interactive* #f) + ;; -s => set argv, don't execute first one + ;; -no-init-file => don't load init file + ;; --no-init-file => don't load init file + ;; --help => print and exit + ;; --version => print and exit + ;; -- => last option + + (let loop ((option (getopt-- argc *argv* opts))) + (case option + ((#\a) + (cond ((> *optind* 3) + (usage "scm: option `-" getopt:opt "' must be first" #f)) + ((or (not (exact? (string->number *optarg*))) + (not (<= 1 (string->number *optarg*) 10000))) + ;; This size limit should match scm.c ^^ + (usage "scm: option `-" getopt:opt + (string-append *optarg* "' unreasonable") #f)))) + ((#\e #\c) (do-string-arg)) ;sh-like + ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*) + ((#\d) (require 'database-utilities) + (open-database *optarg*)) + ((#\o) (require 'dump) + (if (< *optind* (length *argv*)) + (dump *optarg* #t) + (dump *optarg*))) + ((#\r) (do-thunk (lambda () + (if (and (= 1 (string-length *optarg*)) + (char-numeric? (string-ref *optarg* 0))) + (case (string-ref *optarg* 0) + ((#\2) (require 'rev3-procedures) + (require 'rev2-procedures)) + ((#\3) (require 'rev3-procedures)) + ((#\4) (require 'rev4-optional-procedures)) + ((#\5) (require 'dynamic-wind) + (require 'values) + (require 'macro) + (set! *R4RS-macro* #t)) + (else (require (string->symbol *optarg*)))) + (require (string->symbol *optarg*)))))) + ((#\p) (verbose (string->number *optarg*))) + ((#\q) (verbose 0)) + ((#\v) (verbose 3)) + ((#\i) (set! *interactive* #t) ;sh-like + (verbose (max 2 (verbose)))) + ((#\b) (set! didsomething #t) + (set! *interactive* #f)) + ((#\s) (set! moreopts #f) ;sh-like + (set! didsomething #t) + (set! *interactive* #t)) + ((#\m) (set! *R4RS-macro* #t)) + ((#\u) (set! *R4RS-macro* #f)) + ((#\n) (if (not (string=? "o-init-file" *optarg*)) + (usage "scm: unrecognized option `-n" *optarg* "'" #f))) + ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f)) + ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f)) + ((#f) (set! moreopts #f) ;sh-like + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) + (set! *optind* (+ 1 *optind*))))) + (else + (or (cond ((not (string? option)) #f) + ((string-ci=? "no-init-file" option)) + ((string-ci=? "version" option) + (display + (string-append exe-name " " + (scheme-implementation-version) + " +Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +" + up-name + " may be distributed under the terms of" + " the GNU General Public Licence; +certain other uses are permitted as well." + " For details, see the file `COPYING', +which is included in the " + up-name " distribution. +There is no warranty, to the extent permitted by law. +" + )) + (cond ((execpath) + (display " This executable was loaded from ") + (display (execpath)) + (newline))) + (quit #t)) + ((string-ci=? "help" option) + (usage "This is " + up-name + ", a Scheme interpreter." + (string-append + "Latest info: " + "http://www-swiss.ai.mit.edu/~jaffer/" + up-name ".html +" + )) + (quit #t)) + (else #f)) + (usage "scm: unknown option `--" option "'" #f)))) + + (cond ((and moreopts (< *optind* (length *argv*))) + (loop (getopt-- argc *argv* opts))) + ((< *optind* (length *argv*)) ;No more opts + (set! *argv* (list-tail *argv* *optind*)) + (set! *optind* 1) + (cond ((not didsomething) (do-load (car *argv*)) + (set! *optind* (+ 1 *optind*)))) + (cond ((and (> (verbose) 2) + (not (= (+ -1 *optind*) (length *argv*)))) + (display "scm: extra command arguments unused:" + (current-error-port)) + (for-each (lambda (x) (display (string-append " " x) + (current-error-port))) + (list-tail *argv* (+ -1 *optind*))) + (newline (current-error-port))))) + ((and (not didsomething) (= *optind* (length *argv*))) + (set! *interactive* #t))))) + + (cond ((not *interactive*) (quit)) + (*R4RS-macro* + (require 'repl) + (require 'macro) + (let* ((oquit quit)) + (set! quit (lambda () (repl:quit))) + (set! exit quit) + (repl:top-level macro:eval) + (oquit)))) + ;;otherwise, fall into non-macro SCM repl. + ) + (else + (begin (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments))))))) diff --git a/Link.scm b/Link.scm new file mode 100644 index 0000000..ad88e47 --- /dev/null +++ b/Link.scm @@ -0,0 +1,284 @@ +;; Copyright (C) 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. + +;;;; "Link.scm", Compiling and dynamic linking code for SCM. +;;; Author: Aubrey Jaffer. + +(define cc:command + (let ((default "cc -c")) ;-O removed for HP-UX self-compile + (case (software-type) + ((unix) (if (memq 'sun-dl *features*) + "gcc -g -O -fpic -c" ; If you have problems change -fpic to + ; -fPIC (see GCC info pages). + default)) + (else default)))) + +(define link:command + (case (software-type) + (else "cc"))) + +(define scm:object-suffix + (case (software-type) + ((MSDOS VMS) ".OBJ") + (else (if (provided? 'sun-dl) ".so" ".o")))) + +;;; This is an unusual autoload because it should load either the +;;; source or compiled version if present. +(if (not (defined? hobbit)) ;Autoload for hobbit + (define (hobbit . args) + (require (in-vicinity (implementation-vicinity) "hobbit")) + (provide 'hobbit) + (apply hobbit args))) + +(define (compile-file file . args) + (apply hobbit file args) + (require (in-vicinity (implementation-vicinity) "build")) + (build-from-whole-argv + (list "build" "-tdll" + (string-append "--compiler-options=-I" (implementation-vicinity)) + "-c" + (string-append (descmify file) ".c") + ;; or (replace-suffix file (scheme-file-suffix) ".c") + "-hsystem" + ))) + +(define (link-named-scm name . modules) + (require (in-vicinity (implementation-vicinity) "build")) + (let* ((iv (implementation-vicinity)) + (oss (string-append scm:object-suffix " ")) + (command + (list "build" "--type=exe" "-cscm.c" "-hsystem" + (string-append "--linker-options=-L" (implementation-vicinity)) + (apply string-append + "-i" + (map (lambda (n) + (string-append "init_" n)) + modules)) + (apply string-append + "-j" + (map (lambda (n) + (string-append n oss)) modules)) + "-o" name))) + (cond ((>= (verbose) 3) + (write command) (newline))) + (build-from-whole-argv command))) + +;;;; Dynamic linking/loading + +(cond + ((defined? dyn:link) + (define link:modules '()) + (define link:able-suffix + (cond ((provided? 'shl) ".sl") + ((provided? 'sun-dl) ".so") + (else ".o"))) + (define link:link + (lambda (file . libs) + (define oloadpath *load-pathname*) + (let* ((sl (string-length file)) + (lasl (string-length link:able-suffix)) + (*vicinity-suffix* + (case (software-type) + ((NOSVE) '(#\: #\.)) + ((AMIGA) '(#\: #\/)) + ((UNIX) '(#\/)) + ((VMS) '(#\: #\])) + ((MSDOS ATARIST OS/2) '(#\\)) + ((MACOS THINKC) '(#\:)))) + (fname (let loop ((i (- sl 1))) + (cond ((negative? i) file) + ((memv (string-ref file i) *vicinity-suffix*) + (substring file (+ i 1) sl)) + (else (loop (- i 1)))))) + (nsl (string-length fname)) + (name (cond ((< nsl lasl) fname) + ((string-ci=? (substring fname (- nsl lasl) nsl) + link:able-suffix) + (substring fname 0 (- nsl lasl))) + (else fname))) + (linkobj #f)) + (set! *load-pathname* file) + (set! linkobj (assoc name link:modules)) + (cond (linkobj (dyn:unlink (cdr linkobj)))) + (set! linkobj (dyn:link file)) + (for-each (lambda (lib) + (cond ((dyn:link lib)) + (else (slib:error "couldn't link: " lib)))) + libs) + (cond ((not linkobj) + (set! *load-pathname* oloadpath) #f) + ((dyn:call + (string-append + "init_" (list->string (map char-downcase (string->list name)))) + linkobj) + (set! link:modules (acons name linkobj link:modules)) + (set! *load-pathname* oloadpath) #t) + (else + (dyn:unlink linkobj) + (set! *load-pathname* oloadpath) #f))))))) + +(cond + ((defined? vms:dynamic-link-call) + (define link:able-suffix #f) + (define (link:link file) + (define dir "") + (define fil "") + (let loop ((i (- (string-length file) 1))) + (cond ((negative? i) (set! dir file)) + ((memv (string-ref file i) '(#\: #\])) + (set! dir (substring file 0 (+ i 1))) + (set! fil (substring file (+ i 1) (string-length file)))) + (else (loop (- i 1))))) + (vms:dynamic-link-call dir fil (string-append "init_" fil))))) + +(set! *catalog* + (acons 'scmhob (in-vicinity (implementation-vicinity) "scmhob") + *catalog*)) +(and (defined? *catalog*) (defined? link:link) + (cond ((provided? 'dld:dyncm) + (define (usr:lib lib) + (or (and (member lib '("c" "m")) + (let ((sa (string-append "/usr/lib/lib" lib ".sa"))) + (and (file-exists? sa) sa))) + (string-append "/usr/lib/lib" lib ".a"))) + (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))) + ((provided? 'sun-dl) + ;; These libraries are (deferred) linked in conversion to ".so" + (define (usr:lib lib) #f) + (define (x:lib lib) #f)) + ((provided? 'shl) + (define (usr:lib lib) + (if (member lib '("c" "m")) + (string-append "/lib/lib" lib link:able-suffix) + (string-append "/usr/lib/lib" lib link:able-suffix))) + (define (x:lib lib) (string-append "/usr/X11R5/lib/lib" + lib link:able-suffix))) + (else + (define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a")) + (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))) + (begin + (define wb:vicinity (string-append (implementation-vicinity) "../wb/")) + (define (catalog:add-link feature ofile . libs) + (define fe (file-exists? ofile)) + (cond ((or (not (require:feature->path feature)) fe) + ;; remove #f from libs list + (set! libs (let rem ((l libs)) + (cond ((null? l) l) + ((car l) (cons (car l) (rem (cdr l)))) + (else (rem (cdr l)))))) + (set! *catalog* + (acons feature (cons 'compiled (cons ofile libs)) + *catalog*)) + fe) + (else #f))) + (set! *catalog* + (acons 'wb-table (in-vicinity wb:vicinity "wbtab") *catalog*)) + (catalog:add-link 'db + (in-vicinity wb:vicinity "db" link:able-suffix) + (in-vicinity wb:vicinity "handle" link:able-suffix) + (in-vicinity wb:vicinity "blink" link:able-suffix) + (in-vicinity wb:vicinity "prev" link:able-suffix) + (in-vicinity wb:vicinity "ent" link:able-suffix) + (in-vicinity wb:vicinity "sys" link:able-suffix) + (in-vicinity wb:vicinity "del" link:able-suffix) + (in-vicinity wb:vicinity "stats" link:able-suffix) + (in-vicinity wb:vicinity "blkio" link:able-suffix) + (in-vicinity wb:vicinity "scan" link:able-suffix) + (usr:lib "c")) + (set! *catalog* (cons '(wb . db) *catalog*)) + (catalog:add-link 'turtle-graphics + (in-vicinity (implementation-vicinity) "turtlegr" + link:able-suffix) + (x:lib "X11") + (usr:lib "m") + (usr:lib "c")) + (catalog:add-link 'curses + (in-vicinity (implementation-vicinity) "crs" + link:able-suffix) + (usr:lib "ncurses") + ;;(usr:lib "curses") + ;;(usr:lib "termcap") + (usr:lib "c")) + (catalog:add-link 'edit-line + (in-vicinity (implementation-vicinity) "edline" + link:able-suffix) + (usr:lib "edit") + (usr:lib "termcap") + (usr:lib "c")) + (catalog:add-link 'regex + (in-vicinity (implementation-vicinity) "rgx" + link:able-suffix) + (usr:lib "c")) + (catalog:add-link 'unix + (in-vicinity (implementation-vicinity) "unix" + link:able-suffix) + (in-vicinity (implementation-vicinity) "ioext" + link:able-suffix) + (usr:lib "c")) + (catalog:add-link 'posix + (in-vicinity (implementation-vicinity) "posix" + link:able-suffix) + (usr:lib "c")) + (catalog:add-link 'socket + (in-vicinity (implementation-vicinity) "socket" + link:able-suffix) + (usr:lib "c")) + (cond ((catalog:add-link 'i/o-extensions + (in-vicinity (implementation-vicinity) "ioext" + link:able-suffix) + (usr:lib "c")) + (set! *catalog* (append '((line-i/o . i/o-extensions) + (pipe . i/o-extensions)) + *catalog*)))) + (cond ((catalog:add-link 'rev2-procedures + (in-vicinity (implementation-vicinity) "sc2" + link:able-suffix)) + (set! *catalog* (cons '(rev3-procedures . rev2-procedures) + *catalog*)))) + (catalog:add-link 'record + (in-vicinity (implementation-vicinity) "record" + link:able-suffix)) + (catalog:add-link 'generalized-c-arguments + (in-vicinity (implementation-vicinity) "gsubr" + link:able-suffix)) + (catalog:add-link 'array-for-each + (in-vicinity (implementation-vicinity) "ramap" + link:able-suffix)) + )) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..2bb47f6 --- /dev/null +++ b/Makefile @@ -0,0 +1,384 @@ +# Copyright (C) 1990, 1991, 1992, 1993, 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. + +# "Makefile" for scm4e6 Scheme Interpreter +# Author: Aubrey Jaffer + +SHELL = /bin/sh +#CC = +CFLAGS = #-g +#LIBS = +LD = $(CC) #-g + +# directory where COPYING and Init.scm reside. +#IMPLPATH = /usr/local/src/scm/ +#this one is good for bootstrapping +IMPLPATH = `pwd`/ +# Pathname where Init.scm resides. +IMPLINIT = $(IMPLPATH)Init.scm +DFLAG = -DIMPLINIT=\"$(IMPLINIT)\" + +# If pathname where Init.scm resides is not known in advance then +# SCM_INIT_PATH is the environment variable whose value is the +# pathname where Init.scm resides. + +intro: + @echo + @echo "This is scm$(VERSION). Read \"scm.info\" (from \"scm.texi\")" + @echo "to learn how to build and install SCM." + @echo "Here is a quick guide:" + @echo + @echo " From: bos@scrg.cs.tcd.ie" + @echo " Build and install scripts using GNU autoconf are" + @echo " available as scmconfig.tar.gz in the SCM distribution" + @echo " directories. See README.unix in scmconfig.tar.gz for" + @echo " further instructions." + @echo + @echo " Alternatively:" + @echo " make scmlit" + @echo + @echo " If you are on a non-unix system, create an empty file" + @echo " \"scmflags.h\". Then compile time.c, repl.c, scl.c," + @echo " sys.c, eval.c, subr.c, unif.c, and rope.c. Then link" + @echo " them to create a \"scmlit\" executable." + @echo + @echo " Once you have built scmlit successfully, test it:" + @echo " make checklit" + @echo " If this reports no errors, use scmlit to build.scm" + @echo " fancier versions of scm, with optional features." + +ofiles = time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \ + continue.o findexec.o +# ramap.o + +all: scmlit +scmlit: $(ofiles) scm.o + $(LD) -o scmlit $(ofiles) scm.o $(LIBS) +scm.o: scm.c scm.h scmfig.h patchlvl.h scmflags.h + $(CC) $(CFLAGS) -c $(DFLAG) scm.c +scmflags.h: scmflags +scmflags: + echo "#ifndef IMPLINIT" > scmflags.h + echo "#define IMPLINIT \"$(IMPLINIT)\"" >> scmflags.h + echo "#endif" >> scmflags.h + +.c.o: + $(CC) -c $(CFLAGS) $< -o $@ +scl.o: scl.c scm.h scmfig.h scmflags.h +eval.o: eval.c scm.h scmfig.h scmflags.h setjump.h +unif.o: unif.c scm.h scmfig.h scmflags.h +#ramap.o: ramap.c scm.h scmfig.h scmflags.h +repl.o: repl.c scm.h scmfig.h scmflags.h setjump.h +sys.o: sys.c scm.h scmfig.h scmflags.h setjump.h +time.o: time.c scm.h scmfig.h scmflags.h +subr.o: subr.c scm.h scmfig.h scmflags.h +rope.o: rope.c scm.h scmfig.h scmflags.h +continue.o: continue.c continue.h setjump.h + $(CC) $(CFLAGS) -c continue.c + +srcdir=$(HOME)/scm/ + +udscm: + $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \ + engineering-notation dump dynamic-linking -o udscm + +myscm: udscm $(ifiles) + ./udscm -o scm +mylib: + $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \ + engineering-notation dump dynamic-linking -tlib +pgscm: + $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \ + engineering-notation dump dynamic-linking -o udscm \ + --compiler-options=-pg --linker-options=-pg + ./udscm -o pgscm +mydebug: + $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \ + engineering-notation dump dynamic-linking debug -ogdbscm \ + --compiler-options=-Wall --linker-options=-Wall +mydlls: + $(srcdir)build.scm -h system -t dll -c sc2.c rgx.c crs.c edline.c \ + record.c gsubr.c ioext.c posix.c unix.c socket.c \ + ramap.c +myturtle: + $(srcdir)build.scm -h system -F turtlegr -t dll + +checklit: r4rstest.scm + ./scmlit -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' +check: r4rstest.scm + ./scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' +bench: + echo `whoami`@`hostname` testing scm >> BenchLog + echo on `date` >> BenchLog + ls -l scm >> BenchLog + size scm >> BenchLog + uname -a >> BenchLog + ./scm -lbench.scm + cat bench.log >> BenchLog + echo >> BenchLog + echo + tail -20 BenchLog +benchlit: + echo `whoami`@`hostname` testing scmlit >> BenchLog + echo on `date` >> BenchLog + ls -l scmlit >> BenchLog + size scmlit >> BenchLog + uname -a >> BenchLog + ./scmlit -lbench.scm + cat bench.log >> BenchLog + echo >> BenchLog + echo + tail -20 BenchLog + +dvidir=../dvi/ +dvi: $(dvidir)scm.dvi +$(dvidir)scm.dvi: $(srcdir)scm.texi $(dvidir)scm.fn Makefile +# cd $(dvidir);texi2dvi $(srcdir)scm.texi + -(cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;texindex scm.??) + cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;tex $(srcdir)scm.texi +$(dvidir)scm.fn: + cd $(dvidir);tex $(srcdir)scm.texi +xdvi: $(dvidir)scm.dvi + xdvi -s 3 $(dvidir)scm.dvi +htmldir=../public_html/ +html: $(htmldir)scm_toc.html +$(htmldir)scm_toc.html: $(srcdir)scm.texi + cd $(htmldir);make scm_toc.html + +################ INSTALL DEFINITIONS ################ + +prefix = /usr/local/ +exec_prefix = $(prefix)/ +# directory where `make install' will put executable. +bindir = $(exec_prefix)bin/ +libdir = $(exec_prefix)lib/ +# directory where `make install' will put manual page. +man1dir = $(prefix)man/man1/ +infodir = $(prefix)info/ +includedir = $(prefix)include/ + +info: $(infodir)/scm.info +$(infodir)/scm.info: scm.texi + makeinfo scm.texi -o $(infodir)/scm.info + +infoz: $(infodir)/scm.info.gz +$(infodir)/scm.info.gz: $(infodir)/scm.info + -rm $(infodir)/scm.info*.gz + gzip $(infodir)/scm.info* + +install: scm.1 + test -d $(bindir) || mkdir $(bindir) + test -d $(man1dir) || mkdir $(man1dir) + -cp scm $(bindir) + -strip $(bindir)scm + -cp scm.1 $(man1dir) + test -d $(IMPLPATH) || mkdir $(IMPLPATH) + -cp Init.scm $(IMPLPATH) + -cp Link.scm $(IMPLPATH) + -cp Transcen.scm $(IMPLPATH) + -cp COPYING $(IMPLPATH) + +installlib: + test -d $(includedir) || mkdir $(includedir) + cp scm.h $(includedir)scm.h + cp scmfig.h $(includedir)scmfig.h + test -d $(libdir) || mkdir $(libdir) + cp libscm.a $(libdir)libscm.a + +uninstall: + -rm $(bindir)scm + -rm $(man1dir)scm.1 + -rm $(includedir)scm.h + -rm $(includedir)scmfig.h + -rm $(libdir)libscm.a +# -rm $(IMPLPATH)Init.scm +# -cp $(IMPLPATH)Link.scm +# -rm $(IMPLPATH)Transcen.scm +# -rm $(IMPLPATH)COPYING + +scm.doc: scm.1 + nroff -man $< | ul -tunknown >$@ + +#### Stuff for maintaining SCM below #### + +VERSION = 4e6 +ver = $(VERSION) +RM_R = rm -rf +cfiles = scm.c time.c repl.c ioext.c scl.c sys.c eval.c subr.c sc2.c \ + unif.c rgx.c crs.c dynl.c record.c posix.c socket.c unix.c \ + rope.c ramap.c gsubr.c edline.c Iedline.scm continue.c \ + findexec.c +ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c +confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \ + configure configure.in Makefile.in COPYING README.unix + +hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h +ifiles = Init.scm Transcen.scm Link.scm +tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm +dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \ + scm.texi ChangeLog +mfiles = Makefile build.scm build.bat +vfiles = setjump.mar setjump.s +afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \ + $(vfiles) $(ufiles) + +makedev = make -f $(HOME)/makefile.dev +CHPAT=$(HOME)/bin/chpat +dest = $(HOME)/dist/ +temp/scm: $(afiles) + -$(RM_R) temp + mkdir temp + mkdir temp/scm + ln $(afiles) temp/scm + +dist: $(dest)scm$(VERSION).tar.gz +$(dest)scm$(VERSION).tar.gz: temp/scm + $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) tar.gz +shar: scm.shar +scm.shar: temp/scm + $(makedev) PROD=scm shar +dclshar: scm.com +com: scm.com +scm.com: temp/scm + $(makedev) PROD=scm com +zip: scm.zip +scm.zip: temp/scm + $(makedev) PROD=scm zip +distzip: scm$(VERSION).zip +scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm require.scm + $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip + cd ..; zip -9ur $(dest)scm$(VERSION).zip \ + scm/turtle scm/turtlegr.c scm/grtest.scm scm/require.scm + mv $(dest)scm$(VERSION).zip /c/scm/dist/ +pubzip: temp/scm + $(makedev) DEST=$(HOME)/pub/ PROD=scm zip + +diffs: pubdiffs +pubdiffs: temp/scm + $(makedev) DEST=$(HOME)/pub/ PROD=scm pubdiffs +distdiffs: temp/scm + $(makedev) DEST=$(dest) PROD=scm ver=$(ver) distdiffs + + +HOBBITVERSION = 4d +hobfiles = README.hob hobbit.doc hobbit.tms hobbit.scm scmhob.h + +hobtemp/scm: $(hobfiles) + -$(RM_R) hobtemp + mkdir hobtemp + mkdir hobtemp/scm + ln $(hobfiles) hobtemp/scm + +hobdist: $(dest)hobbit$(HOBBITVERSION).tar.gz +$(dest)hobbit$(HOBBITVERSION).tar.gz: hobtemp/scm + $(makedev) DEST=$(dest) PROD=scm ver=-hob$(HOBBITVERSION) \ + tar.gz TEMP=hobtemp/ + mv $(dest)scm-hob$(HOBBITVERSION).tar.gz \ + $(dest)hobbit$(HOBBITVERSION).tar.gz +hobbit$(HOBBITVERSION).zip: hobtemp/scm + $(makedev) TEMP=hobtemp/ name=hobbit$(HOBBITVERSION) PROD=scm zip + +new: + $(CHPAT) scm$(VERSION) scm$(ver) ANNOUNCE ../jacal/ANNOUNCE \ + ../wb/README ../wb/ANNOUNCE \ + ../public_html/README.html ../dist/README \ + ../public_html/SLIB.html ../public_html/JACAL.html \ + ../public_html/SCM.html ../public_html/Hobbit.html \ + /c/scm/dist/install.bat /c/scm/dist/makefile \ + /c/scm/dist/mkdisk.bat + $(CHPAT) $(VERSION) $(ver) README scm.texi patchlvl.h \ + Init.scm ../public_html/SCM.html Makefile + +configtemp/scm: $(confiles) + -$(RM_R) configtemp/scm + -mkdir configtemp + mkdir configtemp/scm + ln $(confiles) configtemp/scm +confdist: scmconfig.tar.gz +scmconfig.tar.gz: configtemp/scm + cd configtemp; tar cohf ../scmconfig.tar scm + chmod 664 scmconfig.tar + -rm -f scmconfig.tar.*z + gzip scmconfig.tar + chmod 664 scmconfig.tar.*z + +lint: lints +lints: $(cfiles) $(hfiles) + lint $(CPPFLAGS) $(ALL_CFLAGS) $(cfiles) | tee lints +# lint $(CPPFLAGS) $(ALL_CFLAGS) $(cfiles) | tee lintes + +#seds to help find names not unique in first 8 characters (name8s) +# for BSD nm format +SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' -e 's/.* T //' +#old, bad for T [^_] on suns: SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' +# For a System V nm where plain C identifiers have _ prepended: +#SED_TO_STRIP_NM=sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//' +# For a System V nm where plain C identifiers have nothing prepended: +#SED_TO_STRIP_NM=sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' + +name8: name8s +name8s: scm + nm scm |\ + $(SED_TO_STRIP_NM) |\ + sort -u|\ + awk '{ if (substr(l,1,8)==substr($$1,1,8)) {\ + if (p) print l;\ + print $$1;p=0;stat=1\ + }else p=1;\ + l=$$1\ + }END{exit stat}' - +ctags: $(hfiles) $(cfiles) + etags $(hfiles) $(cfiles) +TAGS: +tags: $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\ + hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog + etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\ + hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog +mostlyclean: +clean: + -rm -f *~ *.bak *.orig *.rej core a.out ramap.o $(ofiles) scm.o \ + lints tmp* \#* *\# + -$(RM_R) *temp +distclean: clean + -rm -f $(EXECFILES) *.o a.out TAGS +realclean: distclean + -rm -f scm.doc +realempty: temp/scm + -rm -f $(afiles) diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..c2f69c5 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,462 @@ +# Copyright (C) 1990, 1991, 1992, 1993 Aubrey Jaffer. -*- Makefile -*- +# This file is part of SCM. +# +# SCM is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the +# Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# SCM is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +# License for more details. +# +# You should have received a copy of the GNU General Public License +# along with SCM; see the file COPYING. If not, write to the Free +# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +# +# Makefile for SCM +# + +# Ultrix 2.2 make doesn't expand the value of VPATH. +srcdir = @srcdir@ + +CC = @CC@ + +CFLAGS = @CFLAGS@ -I. -I$(srcdir) +LDFLAGS = @LDFLAGS@ + +# Define these for your system as follows: +# -DRTL To create a run-time library only (no +# interactive front end). +# -DRECKLESS To turn most SCM error schecking off. +# -DCAUTIOUS To always check the number of arguments to +# interpreted closures. +# -DIO_EXTENSIONS To get primitives such as chdir, delete-file, +# file-opisition, and pipes. +# -DPROMPT=\"..\" To change the default prompt. +# -DFLOATS To turn on support for inexact numbers. +# -DSINGLES To use single-precision floats (if a float is +# the same size as a long). +# -DSINGLESONLY To make all inexact real numbers to be single +# precision. Only useful if SINGLES is also +# defined. +# -DGC_FREE_SEGMENTS +# To have all segments of unused heap be freed +# up after garbage collection. Do not define if +# you never want the heap to shrink. +# -DTICKS If you want the ticks and ticks-interrupt +# functions defined. +# -DBRACKETS_AS_PARENS +# To have square brackets read as parentheses +# in forms. +# -DMEMOIZE_LOCALS To speed up most local variable references. +# You will need to remove this and recompile +# eval.c if you use very large or deep +# environments (more than 4095 bound variables +# in one procedure). +# -DENGNOT To use engineering notation instead of +# scientific notation. +# -DSICP To make SCM more compatible with the Scheme used +# in Abelson & Sussman's book. +# -DSTACK_LIMIT To limit the maximum growth of the stack (you +# almost certainly don't want this). +# See also `scmconfig.h' and `scmfig.h'. +defines = @DEFS@ \ + -DCAUTIOUS -DARRAYS -DBIGNUMS -DCCLO \ + -DFLOATS -DIO_EXTENSIONS -DMEMOIZE_LOCALS -DGC_FREE_SEGMENTS + +# If you are using user extension files, change INITS and FINALS +# below. INITS makes up the initialization calls for user extension +# files. FINALS defines the finalization calls for user extension +# files. + +# File INITS FINALS functions defined +# +# sc2.c init_sc2\(\) substring-move-left!, +# substring-move-right!, +# substring-fill!, append!, last-pair +# rgx.c init_rgx\(\) regcomp, regexec (POSIX) +# crs.c init_curses\(\) lendwin\(\) ... lots ... + +INITS = -DINITS=init_sc2\(\)\; +FINALS = -DFINALS=\; + +# If you are using rgx.c, set the next line to point to the include +# directory where your POSIX regexp include files live (if you are using +# GNU regex). +# RGXFLAGS = -I/archive/regex-0.11/ + +# If your system needs extra libraries loaded in, define them here. +# -lm For floating point math (needed). +# -lcurses For crs.c extensions. +# -lncurses For curses on Linux (curses has bugs). +# -lterm{cap,lib} May be required for curses support. +# -lregex For POSIX regexp support (rgx.c). +LOADLIBES = @LIBS@ -lm + +# Any extra object files your system needs. +extras = @LIBOBJS@ + +# Common prefix for machine-independent installed files. +prefix = /usr/local +# Common prefix for machine-dependent installed files. +exec_prefix = $(prefix) + +# Name under which to install SCM. +instname = scm +# Directory to install `scm' in. +bindir = $(exec_prefix)/bin +# Directory in which to install Init.scm, COPYING, and Transcen.scm. +libdir = $(exec_prefix)/lib/scm +# Directory to search by default for included makefiles. +includedir = $(prefix)/include +# Directory to install the Info files in. +infodir = $(prefix)/info +# Directory to install the man page in. +mandir = $(prefix)/man/man$(manext) +# Number to put on the man page filename. +manext = 1 +# Directory to perform pre-install tests in. +testdir = $(srcdir) + +# Program to install `scm'. +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +# Program to install the man page. +INSTALL_DATA = @INSTALL_DATA@ +# Generic install program. +INSTALL = @INSTALL@ + +# Program to format Texinfo source into Info files. +MAKEINFO = makeinfo +# Program to format Texinfo source into DVI files. +TEXI2DVI = texi2dvi + +# Programs to make tags files. +ETAGS = etags +CTAGS = ctags -tw + +# You should not need to change below this line. + +SHELL = /bin/sh +DFLAG = -DIMPLINIT=\"$(libdir)/Init.scm\" +TDFLAG = -DIMPLINIT=\"$(testdir)/Init.scm\" +# nunix = nonunix +nunix = $(srcdir) +# examples = examples +examples = $(srcdir) +ffiles = continue.o time.o repl.o fscl.o sys.o feval.o subr.o sc2.o \ +funif.o rope.o ramap.o findexec.o #rgx.o +fifiles = continue.o time.o repl.o iscm.o fscl.o sys.o feval.o subr.o \ +sc2.o funif.o rope.o ramap.o findexec.o #rgx.o +efiles = time.o repl.o escl.o sys.o eeval.o subr.o sc2.o eunif.o #rgx.o +cfiles = $(srcdir)/scm.c $(srcdir)/time.c $(srcdir)/repl.c \ + $(srcdir)/scl.c $(srcdir)/sys.c $(srcdir)/eval.c \ + $(srcdir)/subr.c $(srcdir)/sc2.c $(srcdir)/unif.c \ + $(srcdir)/rgx.c $(srcdir)/crs.c $(srcdir)/dynl.c $(srcdir)/findexec.c +hfiles = $(srcdir)/scm.h $(srcdir)/scmfig.h scmconfig.h \ + $(srcdir)/setjump.h $(srcdir)/patchlvl.h +ifiles = Init.scm Transcen.scm +tfiles = $(examples)/test.scm $(examples)/example.scm \ + $(examples)/pi.scm $(examples)/pi.c $(examples)/split.scm +dfiles = $(srcdir)/README $(srcdir)/COPYING $(srcdir)/scm.1 \ + $(srcdir)/QUICKREF $(srcdir)/MANUAL $(srcdir)/ChangeLog \ + $(srcdir)/code.doc $(srcdir)/ANNOUNCE +mfiles = Makefile $(nunix)/makefile.msc $(nunix)/makefile.bor \ + $(nunix)/makefile.tur $(nunix)/makefile.djg \ + $(nunix)/makefile.emx $(nunix)/makefile.qc \ + $(nunix)/compile.amiga $(nunix)/link.amiga \ + $(nunix)/makefile.aztec $(nunix)/makefile.ast \ + $(nunix)/makefile.prj $(nunix)/dmakefile \ + $(nunix)/makefile.wcc +vfiles = $(nunix)/setjump.mar $(nunix)/VMSBUILD.COM $(nunix)/VMSGCC.COM +afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) $(vfiles) + +.SUFFIXES: +.SUFFIXES: .o .c .h .ps .dvi .info .texinfo .scm + +.PHONY: all +all: scm + +# -DINITS= the initialization calls for user extension files. +# -DFINALS= the finalialization calls for user extension files. +dbscm: escm.a sc2.o $(srcdir)/../wb/db.a $(srcdir)/scm.c $(srcdir)/scm.h \ + $(srcdir)/scmfig.h $(srcdir)/patchlvl.h Makefile + $(CC) -o dbscm $(CFLAGS) $(INITS)init_db\(\)\;init_rgx\(\) \ + $(FINALS)final_db\(\) $(defines) $(srcdir)/scm.c \ + escm.a $(srcdir)/../wb/db.a $(LOADLIBES) $(extras) + rm escm.a +curscm: escm.a crs.o + $(CC) -o curscm $(CFLAGS) $(INITS)init_curses\(\)\;init_rgx\(\) \ + $(FINALS)lendwin\(\) $(srcdir)/scm.c crs.o escm.a -lcurses \ + $(LOADLIBES) $(extras) + rm escm.a +dscm: dscm.a main.o + $(CC) -o dscm $(CFLAGS) main.o -ldld +dscm.a: $(efiles) Makefile dynl.o $(srcdir)/scm.c + $(CC) $(CFLAGS) -DRTL $(INITS)init_dynl\(\) -c $(srcdir)/scm.c + ar crvs dscm.a scm.o dynl.o $(efiles) $(LOADLIBES) +dynl.o: $(srcdir)/dynl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + Makefile + $(CC) $(CFLAGS) -DDLD -DRTL -c $(srcdir)/dynl.c + +instscm: $(fifiles) + $(CC) -o instscm $(fifiles) $(LOADLIBES) $(extras) + +scm: $(ffiles) fscm.o + $(CC) -o scm $(ffiles) fscm.o $(LOADLIBES) $(extras) +fscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h $(srcdir)/patchlvl.h + $(CC) $(CFLAGS) $(TDFLAG) $(defines) -c $(FFLAGS) $(INITS) \ + $(FINALS) $(srcdir)/scm.c + mv scm.o fscm.o + +iscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h $(srcdir)/patchlvl.h + $(CC) $(CFLAGS) $(DFLAG) $(defines) -c $(FFLAGS) $(INITS) \ + $(FINALS) $(srcdir)/scm.c + mv scm.o iscm.o + +fscl.o: $(srcdir)/scl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/scl.c + mv scl.o fscl.o +feval.o: $(srcdir)/eval.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/eval.c + mv eval.o feval.o +funif.o: $(srcdir)/unif.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/unif.c + mv unif.o funif.o + +escm: $(efiles) escm.o + $(CC) -o escm $(efiles) escm.o $(LOADLIBES) $(extras) +escm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h $(srcdir)/patchlvl.h + $(CC) $(CFLAGS) $(defines) -c $(INITS) $(FINALS) $(srcdir)/scm.c + mv scm.o escm.o +escl.o: $(srcdir)/scl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/scl.c + mv scl.o escl.o +eeval.o: $(srcdir)/eval.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/eval.c + mv eval.o eeval.o +eunif.o: $(srcdir)/unif.c $(srcdir)/scm.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c unif.c + mv unif.o eunif.o + +repl.o: $(srcdir)/repl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/setjump.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(TDFLAG) $(srcdir)/repl.c +sys.o: $(srcdir)/sys.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/setjump.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/sys.c +continue.o: $(srcdir)/continue.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/setjump.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/continue.c +rope.o: $(srcdir)/rope.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/setjump.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/rope.c +ramap.o: $(srcdir)/ramap.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/setjump.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/ramap.c +time.o: $(srcdir)/time.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/time.c +subr.o: $(srcdir)/subr.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/subr.c +sc2.o: $(srcdir)/sc2.c $(srcdir)/scm.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/sc2.c +rgx.o: $(srcdir)/rgx.c $(srcdir)/scm.h Makefile scmconfig.h + $(CC) $(CFLAGS) $(defines) $(RGXFLAGS) -c rgx.c +crs.o: $(srcdir)/crs.c $(srcdir)/scm.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c crs.c +findexec.o: $(srcdir)/findexec.c + $(CC) $(CFLAGS) $(defines) -c $(srcdir)/findexec.c + +both: scm escm + +$(srcdir)/proto.h: $(cfiles) + rm -f $(srcdir)/proto.h + mkproto $(cfiles) > $(srcdir)/proto.h + +libscm.a: rtlscm.o $(ffiles) + rm -f libscm.a + ar rc libscm.a rtlscm.o $(ffiles) + $(RANLIB) libscm.a + +rtlscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \ + $(srcdir)/patchlvl.h scmconfig.h + $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) -DRTL $(INITS)init_user_scm\(\) \ + $(FINALS) $(srcdir)/scm.c + mv scm.o rtlscm.o + +.PHONY: install installdirs +install: installdirs \ + $(bindir)/$(instname) $(mandir)/$(instname).$(manext) \ + $(libdir)/Init.scm $(libdir)/Transcen.scm $(libdir)/COPYING + +installdirs: + $(SHELL) ${srcdir}/mkinstalldirs $(bindir) $(infodir) \ + $(mandir) $(libdir) + +$(bindir)/$(instname): instscm + $(INSTALL_PROGRAM) instscm $@.new +# Some systems can't deal with renaming onto a running binary. + -rm -f $@.old + -mv $@ $@.old + mv $@.new $@ + +$(mandir)/$(instname).$(manext): $(srcdir)/scm.1 + $(INSTALL_DATA) $(srcdir)/scm.1 $@ + +$(libdir)/Init.scm: $(srcdir)/Init.scm + $(INSTALL_DATA) $(srcdir)/Init.scm $@ + +$(libdir)/Transcen.scm: $(srcdir)/Transcen.scm + $(INSTALL_DATA) $(srcdir)/Transcen.scm $@ + +$(libdir)/COPYING: $(srcdir)/COPYING + $(INSTALL_DATA) $(srcdir)/COPYING $@ + +.PHONY: tar shar dclshar com zip pubzip +tar: scm.tar +shar: scm.shar +dclshar: scm.com +com: scm.com +zip: scm.zip +scm.tar: temp/scm + cd temp; tar chf ../scm.tar scm + chmod 664 scm.tar +scm.shar: temp/scm + cd temp; shar scm >../scm.shar + chmod 664 scm.shar +scm.com: temp/scm + cd temp; dclshar scm >../scm.com + chmod 664 scm.com +scm.zip: temp/scm + cd temp; zip -r ../scm.zip scm + chmod 664 scm.zip +pubzip: temp/scm + cd temp; zip -ru ../../pub/scm.zip scm + chmod 664 ../pub/scm.zip + +temp/scm: $(afiles) + -rm -rf temp + mkdir temp + mkdir temp/scm + ln $(afiles) temp/scm + +.PHONY: dist tar.Z tar.gz shar.Z +dist: tar.gz +tar.Z: scm.tar.Z +tar.gz: scm.tar.gz +shar.Z: scm.shar.Z +scm.tar.Z: scm.tar + -rm -f scm.tar.Z + compress scm.tar + chmod 664 scm.tar.Z +scm.tar.gz: scm.tar + -rm -f scm.tar.gz + gzip scm.tar + chmod 664 scm.tar.gz +scm.shar.Z: scm.shar + -rm -f scm.shar.Z + compress scm.shar + chmod 664 scm.shar.Z + +.PHONY: pubdiffs distdiffs +pubdiffs: temp/scm + mv temp/scm temp/nscm + cd temp;unzip ../../pub/scm.zip + -rm -f scm.diffs + -diff -c temp/scm temp/nscm > scm.diffs + -rm -rf temp + ls -l scm.diffs +distdiffs: temp/scm + mv temp/scm temp/nscm + cd temp;zcat ../../dist/scm*.tar.gz | tar xvf - + -rm -f scm.pat + -diff -c temp/scm temp/nscm > scm.pat + -rm -rf temp + ls -l scm.pat + +.PHONY: checks check echeck +checks: check echeck +check: ./scm test.scm + echo '(test-sc4)(test-cont)(test-inexact)(gc)(exit (length errs))' \ + | ./scm test.scm +echeck: ./escm test.scm + echo '(test-sc4)(test-cont)(gc)(exit (length errs))' \ + | ./escm test.scm + +.PHONY: lint +lint: lints +lints: $(cfiles) $(hfiles) + lint $(CFLAGS) $(cfiles) | tee lints +# lint $(CFLAGS) $(cfiles) | tee lintes + +# Seds to help find names not unique in first 8 characters (name8s). +# for BSD nm format +# SED_TO_STRIP_NM = sed -e '/.*\.o$$/d' -e 's/.* _//' -e 's/.* T //' +#old, bad for T [^_] on suns: SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' +# For a System V nm where plain C identifiers have _ prepended: +#SED_TO_STRIP_NM = sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//' +# For a System V nm where plain C identifiers have nothing prepended: +#SED_TO_STRIP_NM = sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' +SED_TO_STRIP_NM = : + +.PHONY: name8 +name8: name8s +name8s: scm + nm scm |\ + $(SED_TO_STRIP_NM) |\ + sort -u|\ + awk '{ if (substr(l,1,8)==substr($$1,1,8)) {\ + if (p) print l;\ + print $$1;p=0;stat=1\ + }else p=1;\ + l=$$1\ + }END{exit stat}' - |\ + tee name8s + +tagsrcs = $(hfiles) $(cfiles) $(ifiles) $(mfiles) $(vfiles) \ + MANUAL code.doc README +TAGS: $(tagsrcs) + $(ETAGS) $(tagsrcs) +tags: $(tagsrcs) + $(CTAGS) $(tagsrcs) + +.PHONY: clean cleanish realclean +clean: + -rm -f *~ \#* *.o *\# *.orig *.rej a.out core lints tmp* + -rm -rf temp hobtemp +cleanish: + -rm -f *~ \#* *\# *.orig *.rej a.out core lints tmp* + -rm -rf temp hobtemp +distclean: + -rm -f *~ \#* *.o *\# *.orig *.rej a.out core TAGS lints tmp* \ + scmconfig.h config.status + -rm -rf temp hobtemp + +Makefile: config.status $(srcdir)/Makefile.in + $(SHELL) config.status +scmconfig.h: stamp-config ; +stamp-config: config.status $(srcdir)/scmconfig.h.in + $(SHELL) config.status + touch stamp-config + +configure: configure.in + autoconf $(ACFLAGS) +scmconfig.h.in: configure.in + autoheader $(ACFLAGS) + +# This tells versions [3.59,3.63) of GNU make not to export all variables. +.NOEXPORT: + +# Automatically generated dependencies will be put at the end of the file. diff --git a/QUICKREF b/QUICKREF new file mode 100644 index 0000000..93ca5d4 --- /dev/null +++ b/QUICKREF @@ -0,0 +1,201 @@ +;; FILE "Scheme Sigs" +;; IMPLEMENTS R^4RS Function Signature Synopsis +;; AUTHOR Kenneth A Dickey +;; DATE 1992 October 2 +;; LAST UPDATED 1992 October 3 +;; NOTES: Extracted from Amiga Gambit QuickTour file + +=== FUNCTION SYNOPSIS === + +Notation: + <object> any Scheme data object. + <object>* zero or more objects + <object>+ one or more objects + [<object>] optional object + ( <whatever> )... Zero or more occurances of ( <whatever> ) + +; SYNTAX + + (LAMBDA <name> <exp>+ ) + (LAMBDA (<name>* ) <exp>+ ) + (AND <exp>*) + (OR <exp>*) + (IF <test-exp> <if-true> [<if-false>] ) + (COND (<test> <exp>* )... [(ELSE <exp>+)] ) + (CASE <key-exp> ((<datum>+ ) <exp>* )... [(ELSE <exp>+)] ) + (DEFINE ( <name> <name>* ) <exp>+ ) + (DEFINE <name> <exp> ) + (LET [<name>] ( (<vname> <value-exp>)... ) <exp>+ ) + (LET* ( (<vname> <value-exp>)... ) <exp>+ ) + (LETREC ( (<vname> <value-exp>)... ) <exp>+ ) + (BEGIN <expression>+ ) + (DO ( (<var> <init> <step>)... ) ( <test> <exp>* ) <exp>* ) + ;; Note also R^4RS syntax, below + + +; IEEE Scheme + + (NOT <object>) + (BOOLEAN? <object>) + + (EQ? <obj1> <obj2>) + (EQV? <obj1> <obj2>) + (EQUAL? <obj1> <obj2>) + + (PAIR? <object>) + (CONS <obj1> <obj2>) + (CAR <pair>) + (CDR <pair>) + (SET-CAR! <pair> <object>) + (SET-CDR! <pair> <object>) + (CAAR <list>) (CADR <list>) (CDAR <list>) (CDDR <list>) + (CAAAR <list>) (CAADR <list>) (CADAR <list>) (CADDR <list>) + (CDAAR <list>) (CDADR <list>) (CDDAR <list>) (CDDDR <list>) + (CAAAAR <list>) (CAAADR <list>) (CAADAR <list>) (CAADDR <list>) + (CADAAR <list>) (CADADR <list>) (CADDAR <list>) (CADDDR <list>) + (CDAAAR <list>) (CDAADR <list>) (CDADAR <list>) (CDADDR <list>) + (CDDAAR <list>) (CDDADR <list>) (CDDDAR <list>) (CDDDDR <list>) + (NULL? <object>) + (LIST? <object>) + (LIST <object>* ) + (LENGTH <list>) + (APPEND <list>+ ) + (REVERSE <list>) + (LIST-REF <list> <index>) + + (MEMQ <object> <list>) + (MEMV <object> <list>) + (MEMBER <object> <list>) + + (ASSQ <object> <alist>) + (ASSV <object> <alist>) + (ASSOC <object> <alist>) + + (SYMBOL? <object>) (SYMBOL->STRING <symbol>) (STRING->SYMBOL <string>) + + (NUMBER? <object>) + (COMPLEX? <object>) + (REAL? <object>) + (RATIONAL? <object>) + (INTEGER? <object>) + (EXACT? <number>) (INEXACT? <number>) + (= <number>+ ) + (< <number>+ ) (> <number>+ ) + (<= <number>+ ) (>= <number>+ ) + (ZERO? <number>) + (POSITIVE? <number>) (NEGATIVE? <number>) + (ODD? <number>) (EVEN? <number>) + (MAX <number>+ ) (MIN <number>+ ) + (+ <number>+ ) + (* <number>+ ) + (- <number>+ ) + (/ <number>+ ) + (ABS <number>) + (QUOTIENT <num1> <num2>) (REMAINDER <num1> <num2>) + (MODULO <num1> <num2>) + (GCD <number>* ) (LCM <number>* ) + (NUMERATOR <rational>) (DENOMINATOR <rational>) + (FLOOR <number>) (CEILING <number>) + (TRUNCATE <number>) (ROUND <number>) + (RATIONALIZE <num1> <num2>) + (EXP <number>) (LOG <number>) + (SIN <number>) (COS <number>) (TAN <number>) + (ASIN <number>) (ACOS <number>) (ATAN <number> [<number>]) + (SQRT <number>) + (EXPT <num1> <num2>) + (MAKE-RECTANGULAR <num1> <num2>) (MAKE-POLAR <num1> <num2>) + (REAL-PART <number>) (IMAG-PART <number>) + (MAGNITUDE <number>) (ANGLE <number>) + (EXACT->INEXACT <number>) (INEXACT->EXACT <number>) + (NUMBER->STRING <number>) (STRING->NUMBER <string>) + + (CHAR? <object>) + (CHAR=? <char1> <char2>) (CHAR-CI=? <char1> <char2>) + (CHAR<? <char1> <char2>) (CHAR-CI<? <char1> <char2>) + (CHAR>? <char1> <char2>) (CHAR-CI>? <char1> <char2>) + (CHAR<=? <char1> <char2>) (CHAR-CI<=? <char1> <char2>) + (CHAR>=? <char1> <char2>) (CHAR-CI>=? <char1> <char2>) + (CHAR-ALPHABETIC? <character>) + (CHAR-NUMERIC? <character>) + (CHAR-WHITESPACE? <character>) + (CHAR-UPPER-CASE? <character>) (CHAR-LOWER-CASE? <character>) + (CHAR->INTEGER <character>) (INTEGER->CHAR <integer>) + (CHAR-UPCASE <character>) (CHAR-DOWNCASE <character>) + + (STRING? <object>) + (MAKE-STRING <length> [<character>] ) + (STRING <character>+ ) + (STRING-LENGTH <string>) + (STRING-REF <string> <index>) + (STRING-SET! <string> <index> <character>) + (STRING=? <string1> <string2>) (STRING-CI=? <string1> <string2>) + (STRING<? <string1> <string2>) (STRING-CI<? <string1> <string2>) + (STRING>? <string1> <string2>) (STRING-CI>? <string1> <string2>) + (STRING<=? <string1> <string2>) (STRING-CI<=? <string1> <string2>) + (STRING>=? <string1> <string2>) (STRING-CI>=? <string1> <string2>) + (SUBSTRING <string> <start-index> <end-index>) + (STRING-APPEND <string>+ ) + + (VECTOR? <object>) + (MAKE-VECTOR <length> [<object>] ) + (VECTOR <object>* ) + (VECTOR-LENGTH <vector>) + (VECTOR-REF <vector> <index>) + (VECTOR-SET! <vector> <index> <object>) + + (PROCEDURE? <object>) + (APPLY <procedure> <arg>* <arg-list>) + (MAP <procedure> <list>+ ) + (FOR-EACH <procedure> <list>+ ) + (CALL-WITH-CURRENT-CONTINUATION <one-argument-procedure>) + + (CALL-WITH-INPUT-FILE <string> <procedure>) + (CALL-WITH-OUTPUT-FILE <string> <procedure>) + (INPUT-PORT? <object>) (OUTPUT-PORT? <object>) + (CURRENT-INPUT-PORT) (CURRENT-OUTPUT-PORT) + (OPEN-INPUT-FILE <string>) (OPEN-OUTPUT-FILE <string>) + (CLOSE-INPUT-PORT <input-port>) (CLOSE-OUTPUT-PORT <output-port>) + (EOF-OBJECT? <object>) + (READ [<input-port>] ) + (READ-CHAR [<input-port>] ) + (PEEK-CHAR [<input-port>] ) + (WRITE <object> [<output-port>] ) + (DISPLAY <object> [<output-port>] ) + (NEWLINE [<output-port>] ) + (WRITE-CHAR <character> [<output-port>] ) + + +; R4RS Scheme + + (LIST-TAIL <list> <index>) + (STRING->LIST <string>) + (LIST->STRING <list-of-characters>) + (STRING-COPY <string>) + (STRING-FILL! <string> <character>) + (VECTOR->LIST <vector>) + (LIST->VECTOR <list>) + (VECTOR-FILL! <vector> <object>) + (DELAY <expression>) + (FORCE <promise>) + (WITH-INPUT-FROM-FILE <string> <thunk>) + (WITH-OUTPUT-TO-FILE <string> <thunk>) + (CHAR-READY? [<input-port>] ) + (LOAD <string>) + (TRANSCRIPT-ON <string>) + (TRANSCRIPT-OFF) + + (DEFINE-SYNTAX <name> <transformer-spec>) -- High-Level macros (only) + (LET-SYNTAX ( <syntax-spec>* ) <exp>+ ) + (LETREC-SYNTAX ( <syntax-spec>* ) <exp>+ ) + + + +=== STANDARDS REFERENCES === + + +IEEE Standard 1178-1990. "IEEE Standard for the Scheme Programming +Language", IEEE, New York, 1991, ISBN 1-55937-125-0 [1-800-678-IEEE: +order # SH14209]. -- now also an ANSI standard. + +W. Clinger and J. Rees, eds., "Revised^4 Report on the Algorithmic +Language Scheme", ACM LISP Pointers IV, 3 (July-September 1991). @@ -0,0 +1,384 @@ +This directory contains the distribution of scm4e6. Scm conforms to +Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 +specification. Scm runs under VMS, MS-DOS, OS2, MacOS, Amiga, +Atari-ST, NOS/VE, Unix and similar systems. + +This file consists mainly of excerpts from "scm.info", the result of +compiling (with makeinfo) "scm.texi" to `info' form. In case of +conflicts with "scm.info", consult "scm.info". + +The author can be reached at <jaffer@ai.mit.edu> + + MANIFEST + + `README' is this file. It contains a MANIFEST, INSTALLATION + INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE + SHOOTING GUIDE. + `COPYING' details the LACK OF WARRANTY for scm and the conditions + for distributing scm. + `scm.1' is the unix style man page in nroff format. + `scm.doc' is the text man page generated from scm.1. + `QUICKREF' is a Quick Reference card for IEEE and R4RS. + `scm.texi' details feature support and enhancements to Scheme and + contains a SCHEME BIBLIOGRAPHY. + `ChangeLog' documents changes to the scm. + + `r4rstest.scm' is Scheme code which tests conformance with Scheme + specifications. + `example.scm' is Scheme code from Revised^4 Report on the + Algorithmic Language Scheme which uses inexact numbers. + `pi.scm' is Scheme code for computing digits of pi [type (pi 100 5)] + which can be used to test the performance of scm against + compiled C code [cc -o pi pi.c;time pi 100 5]. + `pi.c' is C code for computing digits of pi. + `bench.scm' is Scheme code for computing and recording speed of + "pi.scm". + + `Makefile' is for building scmlit using the `make' program. + `build.scm' creates a database and program for compiling and linking + new SCM executables, libraries, and dlls. + `build.bat' invokes build.scm on MS-DOS platforms. + `setjump.mar' provides setjmp and longjmp which do not use $unwind + utility on VMS. + `setjump.s' provides setjmp and longjmp for the Cray YMP. + + `Init.scm' is Scheme initialization code. + `Transcen.scm' has Scheme code for inexact builtin procedures. + `Link.scm' has Scheme code for compiling and dynamic linking. + `scmfig.h' is a C include file containing system dependent definitions. + `patchlvl.h is the patchlevel of this release. + `continue.c' code for continuations. + `continue.h' data types and external functions for continuations. + `setjump.h' is an include file dealing with continuations, stacks, + and memory allocation. + `scm.h' has the data type and external definitions of scm. + + `scm.c' has the top level and interrupt code. + `findexec.c' has code to find the executable file. + `time.c' has functions dealing with time. + `repl.c' has error, read-eval-print loop, read, write and load code. + `scl.c' has the code for utility functions which are not part of the + IEEE Scheme spec or which are required for non-integer + arithmetic. + `eval.c' has the evaluator, apply, map, and foreach. + `sys.c' has the code for opening and closing files, storage + allocation and garbage collection. + `rope.c' has C interface functions. + `subr.c' has all the rest of functions. + `sc2.c' has code for procedures from R2RS and R3RS not in R4RS. + `dynl.c' has c code for dynamically loading object files. + `unif.c' has code for uniform vectors. + `rgx.c' has code for string regular expression match. + `crs.c' has code for interactive terminal control. + `split.scm' sets up CURSCM (SCM with crs.c) so that input, output, + and diagnostic output are each directed to separate windows. + `edline.c' Gnu readline input editing + (get ftp.sys.toronto.edu:/pub/rc/editline.shar). + `Iedline.scm' Gnu readline input editing. + `record.c' has code for proposed "Record" user definable datatypes. + `gsubr.c' has make_gsubr for arbitrary (< 11) arguments to C functions. + + `ioext.c' has code for system calls in common between PC compilers and unix. + `posix.c' has code for posix library interface. + `unix.c' has code for non-posix system calls on unix systems. + `socket.c' has code for socket interface. + + SLIB + +[SLIB] is a portable Scheme library meant to provide compatibility and +utility functions for all standard Scheme implementations. Although +SLIB is not *neccessary* to run SCM, I strongly suggest you obtain and +install it. Bug reports about running SCM without SLIB have very low +priority. SLIB is available from the same sites as SCM: + + * ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz + * prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz + * ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz + * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz + +Unpack SLIB (`tar xzf slib2a6.tar.gz' or `unzip -ao slib2a6.zip') in an +appropriate directory for your system; both `tar' and `unzip' will +create the directory `slib'. + +Then create a file `require.scm' in the SCM "implementation-vicinity" +(this is the same directory as where the file `Init.scm' is installed). +`require.scm' should have the contents: + + (define (library-vicinity) "/usr/local/lib/slib/") + (load (in-vicinity (library-vicinity) "require")) + +where the pathname string `/usr/local/lib/slib/' is to be replaced by +the pathname into which you installed SLIB. Absolute pathnames are +recommended here; if you use a relative pathname, SLIB can get confused +when the working directory is changed (*note chmod: I/O-Extensions.). +The way to specify a relative pathname is to append it to the +implementation-vicinity, which is absolute: + + (define library-vicinity + (let ((lv (string-append (implementation-vicinity) "../slib/"))) + (lambda () lv))) + (load (in-vicinity (library-vicinity) "require")) + +Alternatively, you can set the (shell) environment variable +`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note +SCHEME_LIBRARY_PATH: SCM Variables.). If set, the environment variable +overrides `require.scm'. Again, absolute pathnames are recommended. + + MAKING SCM + + The SCM distribution has "Makefile" which contains rules for making +"scmlit", a "bare-bones" version of SCM sufficient for running +`build.scm'. `build.scm' is used to compile (or create scripts to +compile) full featured versions. + + Makefiles are not portable to the majority of platforms. If +`Makefile' works for you, good; If not, I don't want to hear about it. +If you need to compile SCM without build.scm, there are several ways to +proceed: + + * Use SCM on a different platform to run `build.scm' to create a + script to build SCM; + + * Use another implementation of Scheme to run `build.scm' to create a + script to build SCM; + + * Create your own script or `Makefile'. + + * Buy a SCM executable from jaffer@ai.mit.edu. See the end of + `ANNOUNCE' in the distribution for details. + + * Use scmconfig (From: bos@scrg.cs.tcd.ie): + + Build and install scripts using GNU "autoconf" are available from + `scmconfig4e6.tar.gz' in the distribution directories. See + `README.unix' in `scmconfig4e6.tar.gz' for further instructions. + + Making SCM with Think C 4.0 or 4.1 + +Note: These instructions need to be uptdated for scm4e6. If Think C +can be called using system(), then SCM can be built using build.scm. + + Edit Scmfig.H to set desired options and IMPLINIT. + from Yasuaki Honda // honda@csl.SONY.co.jp: + Make a project and add source files repl.c, time.c, scm.c, subr.c, + sys.c, eval.c, scl.c, sc2.c, and unif.c to it. + Add libraries MacTraps, unix, ANSI to the project. + The project should be segmented in the following way: + ---------- + repl.c + scm.c + subr.c + sys.c + sc2.c + unif.c + time.c + ---------- + MacTraps + unix + ---------- + ANSI + ---------- + eval.c + ---------- + scl.c + ---------- + Choose 'Set Project Type' from 'Project' menu. + Choose Application from radio buttons. + Set Partition size to 600K. (The default 384K is not enough). + + EDITING SCHEME CODE + +Gnu Emacs: + Editing of Scheme code is supported by emacs. Buffers holding + files ending in .scm are automatically put into scheme-mode. + + If your Emacs can run a process in a buffer you can use the Emacs + command `M-x run-scheme' with SCM. However, the run-scheme + (`xscheme.el') which comes included with Gnu Emacs 18 will work + only with MIT Cscheme. If you are using Emacs 18, get the emacs + packages: + + * ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el + + * ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el + + These files are already standard in Emacs 19. + + If your Emacs can not run a process in a buffer, see "under other + systems" below. + +Epsilon (MS-DOS): + There is lisp (and scheme) mode available by use of the package + `LISP.E'. It offers several different indentation formats. With + this package, buffers holding files ending in `.L', `.LSP', `.S', + and `.SCM' (my modification) are automatically put into lisp-mode. + + It is possible to run a process in a buffer under Epsilon. With + Epsilon 5.0 the command line options `-e512 -m0' are neccessary to + manage RAM properly. It has been reported that when compiling SCM + with Turbo C, you need to `#define NOSETBUF' for proper operation + in a process buffer with Epsilon 5.0. + + One can also call out to an editor from SCM if RAM is at a + premium; See "under other systems" below. + +other systems: + Define the environment variable `EDITOR' to be the name of the + editing program you use. The SCM procedure `(ed arg1 ...)' will + invoke your editor and return to SCM when you exit the editor. The + following definition is convenient: + + (define (e) (ed "work.scm") (load "work.scm")) + + Typing `(e)' will invoke the editor with the file of interest. + After editing, the modified file will be loaded. + + TROUBLE SHOOTING + +Reported problems and solutions are grouped under "Compiling", +"Linking", "Running", and "Testing". If you don't find your problem +listed here, you can send a bug report to <jaffer@ai.mit.edu>. The +bug report should include: + + * The version of SCM (printed when SCM is invoked with no arguments). + + * The type of computer you are using. + + * The name and version of your computer's operating system. + + * The values of the environment variables SCM_INIT_PATH and + SCHEME_LIBRARY_PATH. + + * The name and version of your C compiler. + + * If you are using an executable from a distribution, the name, + vendor, and date of that distribution. In this case, + corresponding with the vendor is recommended. + + + Compiling: + +FILE ERROR or WARNING HOW TO FIX + +*.c include file not found Correct status of + STDC_HEADERS + + fix #include statement + or add #define for + system type to scmfig.h + +scm.c assignment between incompatible types change SIGRETTYPE in scm.c + +time.c CLK_TCK redefined incompatablility + between <stdlib.h> and + <sys/types.h>. remove + STDC_HEADERS in scmfig.h + + edit <sys/types.h> to + remove incompatability. + +sys.c statement not reached ignore + constant in conditional expression ignore + +sys.c: `???' undeclared, outside of functions #undef STDC_HEADERS + in scmfig.h + +scl.c syntax error define system type in + scmfig.h and scl.c (softtype) + + Linking: + +ERROR or WARNING HOW TO FIX + +_sin etc. missing. uncomment LIBS in makefile + + Running: + +PROBLEM HOW TO FIX + +Opening message and then machine Change memory model option +crashes. to C compiler (or makefile). + + Make sure sizet definition is + correct in scmfig.h + + Reduce size of HEAP_SEG_SIZE + in setjump.h + +Input hangs #define NOSETBUF + +ERROR: heap: need larger initial Need to increase the initial + heap allocation using + -a<kbytes> or INIT_HEAP_SIZE. + +ERROR: Could not allocate ... Check sizet definition. + + Get more memory. + + Don't try to run as subproccess + +... in scmfig.h and recompile scm Do it and recompile files. + +ERROR: Init.scm not found Assign correct IMPLINIT in + makefile or scmfig.h or + define environment variable + SCM_INIT_PATH to be the full + pathname of Init.scm (see + INSTALLATION instructions). + +WARNING: require.scm not found define environment variable + SCHEME_LIBRARY_PATH to be the + full pathname of the scheme + library SLIB or change + library-vicinity in Init.scm + to point to library or remove. + See section SLIB above. + + Make sure library-vicinity has + a trailing file separator + (like / or \). + + Testing: (load "r4rstest.scm") or (load "pi.scm") (pi 100 5) + +Runs some and then machine crashes. See above under machine + crashes. + +Runs some and then ERROR: ... Remove optimization option +(after a GC has happened) to C compiler and recompile. + + #define SHORT_ALIGN in scmfig.h + +Some symbol names print incorrectly. Change memory model option + to C compiler (or makefile). + + Check that HEAP_SEG_SIZE fits + within sizet. + + Increase size of HEAP_SEG_SIZE + (or INIT_HEAP_SIZE if it is + smaller than HEAP_SEG_SIZE). + +ERROR: Rogue pointer in Heap. See above under machine + crashes. + +Newlines don't appear correctly in Check file mode (define OPEN_... +output files. in Init.scm + +Spaces or control characters appear Check character defines in +in symbol names scmfig.h + +Negative numbers turn positive. Check SRS in scmfig.h + +VMS: Couldn't unwind stack #define CHEAP_CONTIUATIONS +VAX: botched longjmp in scmfig.h + +Sparc(SUN-4) heap is growing out of control: + + You are experiencing a GC problem peculiar to the Sparc. The + problem is that SCM doesn't know how to clear register + windows. Every location which is not reused still gets marked + at GC time. This causes lots of stuff which should be + collected to not be. This will be a problem with any + "conservative" GC until we find what instruction will clear + the register windows. This problem is exacerbated by using + lots of call-with-current-continuations. diff --git a/README.unix b/README.unix new file mode 100644 index 0000000..0f9094d --- /dev/null +++ b/README.unix @@ -0,0 +1,182 @@ +This file contains the instructions for building scm4e under Unix +systems. Scm conforms to Revised^4 Report on the Algorithmic Language +Scheme and the IEEE P1178 specification. Scm runs under VMS, MS-DOS, +OS2, MacOS, Amiga, Atari-ST, NOS/VE, Unix and similar systems. + +The author of scm can be reached at <jaffer@ai.mit.edu> or +Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880. + +The Unix installation support included in this scmconfig distribution +has been written by myself, Bryan O'Sullivan <bosullvn@maths.tcd.ie>, +and is maintained by me. Please direct any problems you have with +either scm itself or this configuration software to <bug-scm@scrg.cs.tcd.ie>. + +NOTE: Before you get started, make sure that you have unpacked this + scmconfig distribution into the whatever directory you have + unpacked the same version of scm. + +Several chunks of this file have been lifted more or less verbatim +from the standard INSTALL file which comes with most GNU utilities +these days. + + MANIFEST + + `README.unix' is this file. It contains a MANIFEST, INSTALLATION + INSTRUCTIONS, TROUBLESHOOTING, and various other information. + `COPYING' details the LACK OF WARRANTY for scmconfig and scm and the + conditions for distributing scm and scmconfig. + `acconfig-1.5.h' is a temporary fix for a bug in version 1.5 of GNU + autoconf. This file should not concern you unless you are + familiar with autoconf (you don't need to be). + `configure' is an executable shell script which generates + `scmconfig.h' and `Makefile'. + `configure.in' is a template file used by with autoconf (autoconf is + not needed to build scm), which produces the `configure' + script. + `scmconfig.h.in' is an automatically-generated template file used by + configure, which produces `scmconfig.h'. + `Makefile.in' is a template file used by configure, which produces + `Makefile'. + + INSTALLATION INSTRUCTIONS + +To compile this package: + +1. In the directory that this file is in, type `./configure'. If + you're using `csh' on an old version of System V, you might need + to type `sh configure' instead to prevent `csh' from trying to + execute `configure' itself. + + You may wish to edit the generated `Makefile' file in order to + customise scm to your own preferences. The comments in there + should be adequate to let you decide what you want to do. + `Makefile' has a reasonable set of defaults for most Unix systems, + so you may not have to edit it at all. + +[You can skip the rest of this section (down to point 2 below) the + first time around.] + + The `configure' shell script attempts to guess correct values for + various system-dependent variables used during compilation, and + creates the Makefile. + + Running `configure' takes a minute or two. While it is running, + it prints some messages that tell what it is doing. If you don't + want to see the messages, run `configure' with its standard output + redirected to `/dev/null'; for example, `./configure >/dev/null'. + + To compile the package in a different directory from the one + containing the source code, you must use a version of `make' that + supports the VPATH variable, such as GNU `make'. `cd' to the + directory where you want the object files and executables to go + and run `configure'. `configure' automatically checks for the + source code in the directory that `configure' is in and in `..'. + If for some reason `configure' is not in the source code directory + that you are configuring, then it will report that it can't find + the source code. In that case, run `configure' with the option + `--srcdir=DIR', where DIR is the directory that contains the + source code. + + See the section titled `INSTALL' below on building scm with + different default search paths. By default, when you run `make', + scm looks in the source directory for `Init.scm'. The binary + which is built when you run `make install' looks in the correct + places for files. + + Another `configure' option is useful mainly in `Makefile' rules + for updating `config.status' and `Makefile'. The `--no-create' + option figures out the configuration for your system and records + it in `config.status', without actually configuring the package + (creating `Makefile's and perhaps a configuration header file). + Later, you can run `./config.status' to actually configure the + package. You can also give `config.status' the `--recheck' + option, which makes it re-run `configure' with the same arguments + you used before. This option is useful if you change `configure'. + + `configure' ignores any other arguments that you give it. + + If your system requires unusual options for compilation or linking + that `configure' doesn't know about, you can give `configure' + initial values for some variables by setting them in the + environment. In Bourne-compatible shells, you can do that on the + command line like this: + CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure + +2. Type `make' to compile the package. If you want, you can override + the `make' variables CFLAGS and LDFLAGS like this: + make CFLAGS=-O2 LDFLAGS=-s + +3. Test scm. This is done in the following way (user input comes + after the `bash$' and `>' prompts): + bash$ scm + SCM version xxx, Copyright (C) 1990, 1991, 1992, 1993 Aubrey Jaffer. + SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `(terms)' for details. + ;loading ".../Transcen.scm" + ;done loading ".../Transcen.scm" + ;Evaluation took 230 mSec (0 in gc) 8661 cons work + > (load "test.scm") + ... + > (test-sc4) + ... + > (test-cont) + ... + > (test-inexact) + +4. You can remove the program binaries and object files from the + source directory by typing `make clean'. To also remove the + Makefile(s), the header file containing system-dependent definitions + (if the package uses one), and `config.status' (all the files that + `configure' created), type `make distclean'. + +[You can skip this next bit unless you are editing the `configure.in' + file, which you should not do unless you are familiar with autoconf.] + + If you are using versions of autoconf before or including 1.5, you + should rename `acconfig-1.5.h' to `acconfig.h' before running + autoheader, since these distributions do not handle + `TIME_WITH_SYS_TIME' correctly. + + INSTALL + +Type `make install' to install programs, data files, and +documentation. + +By default, `make install' will install the package's files in +/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify +an installation prefix other than /usr/local by giving `configure' the +option `--prefix=PATH'. Alternately, you can do so by consistently +giving a value for the `prefix' variable when you run `make', e.g., + make prefix=/usr/gnu + make prefix=/usr/gnu install + +You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If +you give `configure' the option `--exec-prefix=PATH' or set the `make' +variable `exec_prefix' to PATH, the package will use PATH as the +prefix for installing programs and libraries. Data files and +documentation will still use the regular prefix. Normally, all files +are installed using the regular prefix. + + TROUBLESHOOTING + +If you encounter any problems while building scm, please send +electronic mail to <bug-scm@scrg.cs.tcd.ie> with a description of the +problem, and any solution to it you may have found. Some mention of +the version of Unix you are trying to build scm on, and the versions +of scm and scmconfig you are using, would be helpful in diagnosing the +problem. + +If you encounter any problems with system include files not being +found, or attempts being made to read the wrong files, please contact +<bug-scm@scrg.cs.tcd.ie> with a description of the include files that +are not being handled correctly; the problem probably lies in the +autoconf support, and can usually be quickly fixed by manually editing +`scmconfig.h'. + +If you find that scm does not link because it cannot find a +time-related function, please mail a description of the problem to +<bug-scm@scrg.cs.tcd.ie>, stating which function(s) can't be found. +In the mean time, editing the top of `time.c' should provide a fix for +the problem. diff --git a/Transcen.scm b/Transcen.scm new file mode 100644 index 0000000..896f77f --- /dev/null +++ b/Transcen.scm @@ -0,0 +1,133 @@ +;; Copyright (C) 1992, 1993, 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. + +;;;; "Transcen.scm", Complex trancendental functions for SCM. +;;; Author: Jerry D. Hedden. + +(define compile-allnumbers #t) ;for HOBBIT compiler + +(define (exp z) + (if (real? z) ($exp z) + (make-polar ($exp (real-part z)) (imag-part z)))) + +(define (log z) + (if (and (real? z) (>= z 0)) + ($log z) + (make-rectangular ($log (magnitude z)) (angle z)))) + +(define (sqrt z) + (if (real? z) + (if (negative? z) (make-rectangular 0 ($sqrt (- z))) + ($sqrt z)) + (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) + +(define expt + (let ((integer-expt integer-expt)) + (lambda (z1 z2) + (cond ((exact? z2) + (integer-expt z1 z2)) + ((and (real? z2) (real? z1) (>= z1 0)) + ($expt z1 z2)) + (else + (exp (* z2 (log z1)))))))) + +(define (sinh z) + (if (real? z) ($sinh z) + (let ((x (real-part z)) (y (imag-part z))) + (make-rectangular (* ($sinh x) ($cos y)) + (* ($cosh x) ($sin y)))))) +(define (cosh z) + (if (real? z) ($cosh z) + (let ((x (real-part z)) (y (imag-part z))) + (make-rectangular (* ($cosh x) ($cos y)) + (* ($sinh x) ($sin y)))))) +(define (tanh z) + (if (real? z) ($tanh z) + (let* ((x (* 2 (real-part z))) + (y (* 2 (imag-part z))) + (w (+ ($cosh x) ($cos y)))) + (make-rectangular (/ ($sinh x) w) (/ ($sin y) w))))) + +(define (asinh z) + (if (real? z) ($asinh z) + (log (+ z (sqrt (+ (* z z) 1)))))) + +(define (acosh z) + (if (and (real? z) (>= z 1)) + ($acosh z) + (log (+ z (sqrt (- (* z z) 1)))))) + +(define (atanh z) + (if (and (real? z) (> z -1) (< z 1)) + ($atanh z) + (/ (log (/ (+ 1 z) (- 1 z))) 2))) + +(define (sin z) + (if (real? z) ($sin z) + (let ((x (real-part z)) (y (imag-part z))) + (make-rectangular (* ($sin x) ($cosh y)) + (* ($cos x) ($sinh y)))))) +(define (cos z) + (if (real? z) ($cos z) + (let ((x (real-part z)) (y (imag-part z))) + (make-rectangular (* ($cos x) ($cosh y)) + (- (* ($sin x) ($sinh y))))))) +(define (tan z) + (if (real? z) ($tan z) + (let* ((x (* 2 (real-part z))) + (y (* 2 (imag-part z))) + (w (+ ($cos x) ($cosh y)))) + (make-rectangular (/ ($sin x) w) (/ ($sinh y) w))))) + +(define (asin z) + (if (and (real? z) (>= z -1) (<= z 1)) + ($asin z) + (* -i (asinh (* +i z))))) + +(define (acos z) + (if (and (real? z) (>= z -1) (<= z 1)) + ($acos z) + (+ (/ (angle -1) 2) (* +i (asinh (* +i z)))))) + +(define (atan z . y) + (if (null? y) + (if (real? z) ($atan z) + (/ (log (/ (- +i z) (+ +i z))) +2i)) + ($atan2 z (car y)))) diff --git a/acconfig-1.5.h b/acconfig-1.5.h new file mode 100644 index 0000000..4f33b04 --- /dev/null +++ b/acconfig-1.5.h @@ -0,0 +1,22 @@ +/* acconfig.h + This file is in the public domain. + + Descriptive text for the C preprocessor macros that + the distributed Autoconf macros can define. + No software package will use all of them; autoheader copies the ones + your configure.in uses into your configuration header file templates. + + The entries are in sort -df order: alphabetical, case insensitive, + ignoring punctuation (such as underscores). + + Leave the following blank line there!! Autoheader needs it. */ + + +/* Define if <sys/time.h> and <time.h> do not clash with each other. */ +#undef TIME_WITH_SYS_TIME + + +/* Leave that blank line there!! Autoheader needs it. + If you're adding to this file, keep in mind: + The entries are in sort -df order: alphabetical, case insensitive, + ignoring punctuation (such as underscores). */ diff --git a/bench.scm b/bench.scm new file mode 100644 index 0000000..acb4a2c --- /dev/null +++ b/bench.scm @@ -0,0 +1,55 @@ + +(require (in-vicinity (implementation-vicinity) "pi.scm")) +(require 'transcript) +(define isqrt + (cond ((provided? 'inexact) sqrt) + (else (require 'root) integer-sqrt))) +(define i/ + (cond ((provided? 'inexact) /) + (else quotient))) +(define around + (cond ((provided? 'inexact) + (lambda (x) + (cond ((>= 3000 (abs x) 3) (inexact->exact (round x))) + (else x)))) + (else identity))) + +(define (time-pi digits) + (let ((start-time (get-internal-run-time))) + (pi digits 4) + (i/ (* 1000 (- (get-internal-run-time) start-time)) + internal-time-units-per-second))) + +(define (benchmark . arg) + (define file + (cond ((null? arg) "bench.log") + (else (car arg)))) + (do ((digits 50 (+ digits digits)) + (t 0 (time-pi (+ digits digits)))) + ((> t 3000) + (do ((tl '() (cons (time-pi digits) tl)) + (j 12 (+ -1 j))) + ((zero? j) + (let* ((avg (i/ (apply + tl) (length tl))) + (dev (isqrt (i/ (apply + + (map (lambda (x) (* (- x avg) (- x avg))) + tl)) + (length tl))))) + (and file (transcript-on file)) + (for-each display + (list digits " digits took " (around avg) " mSec +/- " + (around dev) " mSec.")) + (newline) + (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))) + (for-each display + (list " That is about " scaled-avg + " mSec/k-digit^2 +/- " + (around + (i/ (* 100 (i/ (* (i/ (* dev 1000) digits) + 1000) digits)) + scaled-avg)) + "%.")) + (newline) + (and file (transcript-off))) + )))))) +(benchmark) diff --git a/build.bat b/build.bat new file mode 100755 index 0000000..723e25e --- /dev/null +++ b/build.bat @@ -0,0 +1 @@ +scm -f %0 -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/build.scm b/build.scm new file mode 100755 index 0000000..557a5ab --- /dev/null +++ b/build.scm @@ -0,0 +1,1393 @@ +#!/bin/sh +type;exec scmlit -f $0 -e"(bi)" build $* +;;; "build.scm" Build database and program -*-scheme-*- +;;; Copyright (C) 1994, 1995, 1996 Aubrey Jaffer. +;;; See the file `COPYING' for terms applying to this program. + +(require 'getopt) +(require 'parameters) +(require 'database-utilities) + +;;;(define build (create-database "buildscm.scm" 'alist-table)) +(define build (create-database #f 'alist-table)) + +(require 'batch) +(batch:initialize! build) + +(define-tables build + + '(file-formats + ((format symbol)) + () + ((plaintext) + (c-source) + (c-header) + (scheme) + (vax-asm) + (cray-asm) + (makefile) + (MS-DOS-batch) + (nroff) + (texinfo))) + + '(file-categories + ((category symbol)) + ((documentation string)) + ((documentation "Documentation file (or source for)") + (required "File required for building executable SCM") + (optional "File required for some feature") + (linkable "File whose object can be dynamically linked") + (test "File to test SCM") + (none "No files"))) + + '(build-whats + ((name symbol)) + ((class file-categories) + (c-proc symbol) + (o-proc symbol) + (spec expression) + (documentation string)) + ((exe required compile-c-files link-c-program #f + "executable program") + (lib required compile-c-files make-archive ((define "RTL")) + "library module") + (dlls linkable compile-dll-c-files make-dll-archive ((define "RTL")) + "archived dynamically linked library object files") + (dll none compile-dll-c-files make-nothing #f + "dynamically linked library object file"))) + + '(manifest + ((file string)) + ((format file-formats) + (category file-categories) + (documentation string)) + (("README" plaintext documentation "contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE.") + ("COPYING" plaintext documentation "details the LACK OF WARRANTY for SCM and the conditions for distributing SCM.") + ("scm.1" nroff documentation "unix style man page.") + ("scm.doc" plaintext documentation "man page generated from scm.1.") + ("QUICKREF" plaintext documentation "Quick Reference card for R4RS and IEEE Scheme.") + ("scm.texi" Texinfo documentation "SCM installation and use.") + ("ChangeLog" plaintext documentation "changes to SCM.") + ("r4rstest.scm" Scheme test "tests conformance with Scheme specifications.") + ("example.scm" Scheme test "example from R4RS which uses inexact numbers.") + ("pi.scm" Scheme test "computes digits of pi [type (pi 100 5)]. Test performance against pi.c.") + ("pi.c" c-source test "computes digits of pi [cc -o pi pi.c;time pi 100 5].") + ("bench.scm" Scheme test "computes and records performance statistics of pi.scm.") + ("Makefile" Makefile required "builds SCMLIT using the `make' program.") + ("build.scm" Scheme required "database for compiling and linking new SCM programs.") + ("build.bat" MS-DOS-batch optional "invokes build.scm for MS-DOS") + ("setjump.mar" Vax-asm optional "provides setjmp and longjmp which do not use $unwind utility on VMS.") + ("setjump.s" Cray-asm optional "provides setjmp and longjmp for the Cray YMP.") + ("Init.scm" Scheme required "Scheme initialization.") + ("Transcen.scm" Scheme required "inexact builtin procedures.") + ("Link.scm" Scheme required "compiles and dynamically links.") + ("scmfig.h" c-header required "contains system dependent definitions.") + ("patchlvl.h" c-header required "patchlevel of this release.") + ("setjump.h" c-header required "continuations, stacks, and memory allocation.") + ("continue.h" c-header required "continuations.") + ("continue.c" c-source required "continuations.") + ("scm.h" c-header required "data type and external definitions of SCM.") + ("scm.c" c-source required "top level, interrupts, and non-IEEE utility functions.") + ("findexec.c" c-source required "find the executable file function.") + ("time.c" c-source required "functions dealing with time.") + ("repl.c" c-source required "error, read-eval-print loop, read, write and load.") + ("scl.c" c-source required "inexact arithmetic") + ("eval.c" c-source required "evaluator, apply, map, and foreach.") + ("sys.c" c-source required "call-with-current-continuation, opening and closing files, storage allocation and garbage collection.") + ("subr.c" c-source required "the rest of IEEE functions.") + ("unif.c" c-source required "uniform vectors.") + ("rope.c" c-source required "C interface functions.") + ("ramap.c" c-source optional "array mapping") + ("dynl.c" c-source optional "dynamically load object files.") + ("sc2.c" c-source linkable "procedures from R2RS and R3RS not in R4RS.") + ("rgx.c" c-source linkable "string regular expression match.") + ("crs.c" c-source linkable "interactive terminal control.") + ("split.scm" Scheme test "example use of crs.c. Input, output, and diagnostic output directed to separate windows.") + ("edline.c" c-source linkable "Gnu readline input editing (get ftp.sys.toronto.edu:/pub/rc/editline.shar).") + ("Iedline.scm" Scheme optional "Gnu readline input editing.") + ("record.c" c-source linkable "proposed `Record' user definable datatypes.") + ("gsubr.c" c-source linkable "make_gsubr for arbitrary (< 11) arguments to C functions.") + ("ioext.c" c-source linkable "system calls in common between PC compilers and unix.") + ("posix.c" c-source linkable "posix library interface.") + ("unix.c" c-source linkable "non-posix system calls on unix systems.") + ("socket.c" c-source linkable "BSD socket interface.") + ("pre-crt0.c" c-source optional "loaded before crt0.o on machines which do not remap part of the data space into text space in unexec.") + ("ecrt0.c" c-source optional "standard Vax 4.2 Unix crt0.c cannot be used because it makes `envron' an initialized variable.") + ("gmalloc.c" c-source optional "Gnu malloc().") + ("unexec.c" c-source optional "Convert a running program into an a.out file.") + ("unexelf.c" c-source optional "Convert a running ELF program into an a.out file.") + ))) + +(for-each (build 'add-domain) + '((optstring #f (lambda (x) (or (not x) (string? x))) string #f) + (filename #f #f string #f) + (build-whats #f #f symbol #f))) + +(define-tables build + + '(processor-family + ((family atom)) + ((also-runs processor-family)) + ((*unknown* #f) + (8086 #f) + (acorn #f) + (cray #f) + (hp-risc #f) + (i386 8086) + (m68000 #f) + (m68030 m68000) + (mips #f) + (nos/ve #f) + (pdp-10 #f) + (pdp-11 #f) + (pdp-8 #f) + (powerpc #f) + (pyramid #f) + (sequent #f) + (sparc #f) + (tahoe #f) + (vax pdp-11) + )) + + '(platform + ((name symbol)) + ((processor processor-family) + (operating-system operating-system) + (compiler symbol)) + ((*unknown* *unknown* unix *unknown*) + (acorn-unixlib acorn *unknown* *unknown*) + (aix powerpc aix *unknown*) + (amiga-aztec m68000 amiga aztec) + (amiga-dice-c m68000 amiga dice-c) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari.st gcc) + (atari-st-turbo-c m68000 atari.st turbo-c) + (borland-c-3.1 8086 ms-dos borland-c) + (djgpp i386 ms-dos gcc) + (gcc *unknown* unix gcc) + (highc.31 i386 ms-dos highc) + (hp-ux hp-risc hp-ux *unknown*) + (linux-aout i386 linux gcc) + (linux i386 linux gcc) + (microsoft-c 8086 ms-dos microsoft-c) + (microsoft-c-nt i386 ms-dos microsoft-c) + (microsoft-quick-c 8086 ms-dos microsoft-quick-c) + (ms-dos 8086 ms-dos *unknown*) + (os/2-cset i386 os/2 C-Set++) + (os/2-emx i386 os/2 gcc) + (sun sparc sun-os *unknown*) + (svr4 *unknown* unix *unknown*) + (turbo-c-2 8086 ms-dos turbo-c) + (unicos cray unicos *unknown*) + (unix *unknown* unix *unknown*) + (vms vax vms *unknown*) + (vms-gcc vax vms gcc) + (watcom-9.0 i386 ms-dos watcom) + )) + + '(C-libraries + ((library symbol) + (platform platform)) + ((compiler-flags string) + (link-lib-flag string) + (lib-path optstring) + (supress-files expression)) + + ((m *unknown* "" "-lm" "/usr/lib/libm.a" ()) + (c *unknown* "" "-lc" "/usr/lib/libc.a" ()) + (regex *unknown* "" "-lrgx" "/usr/lib/librgx.a" ()) + (curses *unknown* "" "-lcurses" "/usr/lib/libcurses.a" ()) + (graphics *unknown* "-I/usr/X11/include -DX11" "-lX11" + "/usr/X11/lib/libX11.sa" ()) + (editline *unknown* "" "-ledit" "/usr/lib/libedit.a" ()) + (termcap *unknown* "" "-ltermcap" "/usr/lib/libtermcap.a" ()) + (debug *unknown* "-g" "-g" #f ()) + + (m linux-aout "" "-lm" "/usr/lib/libm.sa" ()) + (c linux-aout "" "-lc" "/usr/lib/libc.sa" ()) + (dlll linux-aout "-DDLD -DDLD_DYNCM" "-ldld" #f ("findexec.c")) + (regex linux-aout "" "" "" ()) + (curses linux-aout "-I/usr/include/ncurses" "-lncurses" + "/usr/lib/libncurses.a" ()) + (nostart linux-aout "" "-nostartfiles" #f ("ecrt0.c")) + (dump linux-aout "" "/usr/lib/crt0.o" #f ("unexelf.c")) + + (m linux "" "-lm" "/lib/libm.so" ()) + (c linux "" "-lc" "/lib/libc.so" ()) + (dlll linux "-DSUN_DL" "-ldl" #f ()) + (graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11" + "/usr/X11R6/lib/libX11.so" ()) + (curses linux "" "-lcurses" "/lib/libncurses.so" ()) + (nostart linux "" "" #f ("pre-crt0.c" "ecrt0.c")) + (dump linux "" "" #f ("unexec.c")) + + (m acorn-unixlib "" "" #f ()) + + (m amiga-dice-c "" "-lm" #f ()) + (m amiga-SAS/C-5.10 "" "lcmieee.lib" #f ()) + (c amiga-SAS/C-5.10 "" "lc.lib" #f ()) + + (m vms-gcc "" "" #f ()) + (m vms "" "" #f ()) + + (m atari-st-gcc "" "-lpml" #f ()) + (m atari-st-turbo-c "" "" #f ()) + + (m sun "" "-lm" #f ()) + (dlll sun "-DSUN_DL" "-ldl" #f ()) + (nostart sun "" "-e __start -nostartfiles -static" #f ("pre-crt0.c")) + (dump sun "" "" #f ("unexec.c")) + + (m hp-ux "" "-lm" #f ()) + (dlll hp-ux "-DHAVE_DYNL" "-Wl,-E -ldld" #f ()) + (graphics hp-ux "-DX11" "-lX" "/usr/lib/X11R5/libX11.sl" ()) + + (c djgpp "" "-lc" #f ("findexec.c")) + (curses djgpp "-I/djgpp/contrib/pdcurses/include/" + "-L/djgpp/contrib/pdcurses/lib/ -lcurses" + "\\djgpp\\contrib\\pdcurses\\lib\\libcurse.a" ()) + (nostart djgpp "" "-nostartfiles" #f ("ecrt0.c")) + (dump djgpp "" "c:/djgpp/lib/crt0.o" #f ("unexelf.c")) + + (c Microsoft-C "" "" #f ("findexec.c")) + (m Microsoft-C "" "" #f ()) + (c Microsoft-C-nt "" "" #f ("findexec.c")) + (m Microsoft-C-nt "" "" #f ()) + (c Microsoft-Quick-C "" "" #f ("findexec.c")) + (m Microsoft-Quick-C "" "" #f ()) + + (c Turbo-C-2 "" "" #f ("findexec.c")) + (m Turbo-C-2 "" "" #f ()) + (graphics Turbo-C-2 "" "graphics.lib" #f ()) + + (c Borland-C-3.1 "" "" #f ("findexec.c")) + (m Borland-C-3.1 "" "" #f ()) + (graphics Borland-C-3.1 "" "graphics.lib" #f ()) + (windows Borland-C-3.1 "-N -W" "-W" #f ()) + + (c highc.31 "" "" #f ("findexec.c")) + (m highc.31 "" "" #f ()) + (windows highc.31 "-Hwin" "-Hwin" #f ()) + )) + + '(compile-commands + ((name symbol) + (platform platform)) + ((procedure expression)) + + ((compile-c-files Borland-C-3.1 + (lambda (files parms) + (define rsp-name "temp.rsp") + (apply batch:lines->file parms rsp-name files) + (batch:system parms + "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c" + (if (member '(define "FLOATS" #t) + (c-defines parms)) + "" "-f-") + (c-includes parms) + (c-flags parms) + (string-append "@" rsp-name)) + (replace-suffix files ".c" ".obj"))) + (link-c-program Borland-C-3.1 + (lambda (oname objects libs parms) + (define lnk-name (string-append oname ".lnk")) + (apply batch:lines->file parms + lnk-name + (append libs objects)) + (batch:system parms "bcc" + (string-append "-e" oname) + "-ml" + (string-append "@" lnk-name)) + (string-append oname ".exe"))) + + (compile-c-files Turbo-C-2 + (lambda (files parms) + (batch:system parms + "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c" + "-Ic:\\turboc\\include" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program Turbo-C-2 + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (if (not (string-ci=? exe oexe)) + (batch:delete-file parms oexe)) + (batch:system parms + "tcc" "-Lc:\\turboc\\lib" libs objects) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + + (compile-c-files Microsoft-C + (lambda (files parms) + (batch:system parms + "cl" "-c" "Oxp" "-AH" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program Microsoft-C + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (if (not (string-ci=? exe oexe)) + (batch:delete-file parms oexe)) + (batch:system parms + "link" "/noe" "/ST:40000" + (apply string-join "+" + (map (lambda (o) + (replace-suffix o ".obj" "")) + objects)) + libs) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + (compile-c-files Microsoft-C-nt + (lambda (files parms) + (batch:system parms + "cl" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program Microsoft-C-nt + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (if (not (string-ci=? exe oexe)) + (batch:delete-file parms oexe)) + (batch:system parms + "link" + (apply string-join " " + (map (lambda (o) + (replace-suffix o ".obj" "")) + objects)) + libs) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + + (compile-c-files Microsoft-Quick-C + (lambda (files parms) + (batch:system parms + "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program Microsoft-Quick-C + (lambda (oname objects libs parms) + (define crf-name (string-append oname ".crf")) + (apply batch:lines->file parms + crf-name + `(,@(map (lambda (f) (string-append f " +")) + objects) + "" + ,(string-append oname ".exe") + ,(apply string-join " " libs) + ";")) + (batch:system parms + "qlink" + "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40" + crf-name) + (string-append oname ".exe"))) + + (compile-c-files Watcom-9.0 + (lambda (files parms) + (batch:system parms + "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s" + "/zq" "/w3" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program Watcom-9.0 + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) + ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (if (not (string-ci=? exe oexe)) + (batch:delete-file parms oexe)) + (batch:system parms + "wlinkp" "option" "quiet" "option" + "stack=40000" "FILE" + (apply string-join "," + (map (lambda (o) + (replace-suffix o ".obj" "")) + objects)) + libs) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + (compile-c-files highc.31 + (lambda (files parms) + (define hcc-name "temp.hcc") + (apply batch:lines->file parms hcc-name files) + (batch:system parms + "\\hi_c\\hc386.31\\bin\\hc386" + (c-includes parms) + (c-flags parms) + "-c" (string-append "@" hcc-name)) + (replace-suffix files ".c" ".obj"))) + (link-c-program highc.31 + (lambda (oname objects libs parms) + (let ((oexe (string-append oname ".exe"))) + (define lnk-name (string-append oname ".lnk")) + (apply batch:lines->file parms + lnk-name (append libs objects)) + (batch:system parms + "\\hi_c\\hc386.31\\bin\\hc386" "-o" oname + (string-append "@" lnk-name)) + (batch:system parms + "bind386" "/hi_c/pharlap.51/run386b.exe" oname + "-exe" oexe) + oexe))) + + (compile-c-files djgpp + (lambda (files parms) + (batch:apply-chop-to-fit + batch:try-system parms + "gcc" "-Wall" "-O2" "-c" + (c-includes parms) (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program djgpp + (lambda (oname objects libs parms) + (let ((exe (string-append oname ".exe"))) + (or + (batch:try-system parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "c:/djgpp/lib/crt0.o") + (append objects libs))) + (let ((arname (string-append oname ".a"))) + (batch:delete-file parms arname) + (batch:apply-chop-to-fit + batch:try-system parms + "ar" "r" arname objects) + (batch:system + parms "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "c:/djgpp/lib/crt0.o") + (cons arname libs)))) + (slib:error 'build "couldn't build archive")) + (batch:system parms "strip" oname) + (batch:delete-file parms exe) + (batch:system parms + "coff2exe" "-s" + "c:\\djgpp\\bin\\go32.exe" + oname) + exe))) + + (compile-c-files os/2-emx + (lambda (files parms) + (batch:system parms + "gcc" "-O" "-m386" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program os/2-emx + (lambda (oname objects libs parms) + (batch:system parms + "gcc" "-o" (string-append oname ".exe") + objects libs) + (string-append oname ".exe"))) + + (compile-c-files os/2-cset + (lambda (files parms) + (batch:system parms + "icc.exe" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".obj"))) + (link-c-program os/2-cset + (lambda (oname objects libs parms) + (batch:system parms + "link386.exe" objects libs + (string-append "," oname ".exe,,,;")) + (string-append oname ".exe"))) + + (compile-c-files HP-UX + (lambda (files parms) + (batch:system parms + "cc" "+O1" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (compile-dll-c-files HP-UX + (lambda (files parms) + (batch:system parms + "cc" "+O1" "-Wl,-E" "+z" "-c" + (c-includes parms) + (c-flags parms) + files) + (for-each + (lambda (fname) + (batch:rename-file parms + (string-append fname ".sl") + (string-append fname ".sl~")) + (batch:system parms + "ld" "-b" "-o" + (string-append fname ".sl") + (string-append fname ".o"))) + (replace-suffix files ".c" "")) + (replace-suffix files ".c" ".sl"))) +; (make-dll-archive HP-UX +; (lambda (oname objects libs parms) +; (batch:system parms +; "ld" "-b" "-o" (string-append oname ".sl") +; objects) +; (string-append oname ".sl"))) + + (make-dll-archive sun + (lambda (oname objects libs parms) + (batch:system parms + "ld" "-assert" "pure-text" "-o" + (string-append oname ".so.1.0") + objects) + (string-append oname ".so.1.0"))) + + (compile-c-files linux-aout + (lambda (files parms) + (batch:system parms + "gcc" "-Wall" "-O2" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (compile-dll-c-files linux-aout + (lambda (files parms) + (batch:system parms + "gcc" "-Wall" "-O2" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) +;;; (make-dll-archive linux-aout +;;; (lambda (oname objects libs parms) #t +;;; oname)) + + (compile-c-files linux + (lambda (files parms) + (batch:system parms + "gcc" "-O2" "-c" (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (compile-dll-c-files linux + (lambda (files parms) + (batch:system parms + "gcc" "-O2" "-fpic" "-c" (c-includes parms) + (c-flags parms) + files) + (let* ((platform (car (parameter-list-ref + parms 'platform))) + (ld-opts + (map (lambda (l) + (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib)))) + (for-each + (lambda (fname) + (batch:system parms + "gcc" "-shared" "-o" + (string-append fname ".so") + (string-append fname ".o") + ld-opts)) + (replace-suffix files ".c" ""))) + (replace-suffix files ".c" ".so"))) + (make-dll-archive linux + (lambda (oname objects libs parms) + (let ((platform (car (parameter-list-ref + parms 'platform)))) + (batch:system + parms + "gcc" "-shared" "-o" + (string-append oname ".so") + objects + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib)))) + (string-append oname ".so"))) + (link-c-program linux + (lambda (oname objects libs parms) + (batch:system parms + "gcc" "-rdynamic" "-o" oname + (must-be-first + '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o") + (append objects libs))) + oname)) + + (compile-c-files Unicos + (lambda (files parms) + (batch:system parms + "cc" "-hvector2" "-hscalar2" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program Unicos + (lambda (oname objects libs parms) + (batch:system parms + "cc" "setjump.o" "-o" oname objects libs) + oname)) + + (compile-c-files gcc + (lambda (files parms) + (batch:system parms + "gcc" "-Wall" "-O2" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + + (link-c-program gcc + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (batch:system parms + "gcc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname)) + + (compile-c-files svr4 + (lambda (files parms) + (batch:system parms + "cc" "-O" "-DSVR4" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + + (compile-c-files aix + (lambda (files parms) + (batch:system parms + "cc" "-O" "-Dunix" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program aix + (lambda (oname objects libs parms) + (batch:system parms + "cc" "-lansi" "-o" oname objects libs) + oname)) + + (compile-c-files amiga-aztec + (lambda (files parms) + (batch:system parms + "cc" "-dAMIGA" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program amiga-aztec + (lambda (oname objects libs parms) + (batch:system parms + "cc" "-o" oname objects libs "-lma") + oname)) + + (compile-c-files amiga-SAS/C-5.10 + (lambda (files parms) + (batch:system parms + "lc" "-d3" "-M" "-fi" "-O" + (c-includes parms) + (c-flags parms) + files) + (batch:system parms "blink with link.amiga NODEBUG") + (replace-suffix files ".c" ".o"))) + (link-c-program amiga-SAS/C-5.10 + (lambda (oname objects libs parms) + (define lnk-name "link.amiga") + (apply batch:lines->file parms + lnk-name + (apply string-join "+" ">FROM LIB:c.o" + (map object->string objects)) + (string-append + "TO " (object->string (string-append "/" oname))) + (append + (cond + ((pair? libs) + (cons (string-append "LIB LIB:" (car libs)) + (map (lambda (s) + (string-append " LIB:" s)) + (cdr libs)))) + (else '())) + '("VERBOSE" "SC" "SD"))) + oname)) + + (compile-c-files amiga-dice-c + (lambda (files parms) + (batch:system parms + "dcc" "-r" "-gs" "-c" + (c-includes parms) + (c-flags parms) + files "-o" (replace-suffix files ".c" ".o")) + (replace-suffix files ".c" ".o"))) + (link-c-program amiga-dice-c + (lambda (oname objects libs parms) + (batch:system parms + "dcc" "-r" "-gs" "-o" oname objects libs) + oname)) + + (compile-c-files atari-st-gcc + (lambda (files parms) + (batch:system parms + "gcc" "-v" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program atari-st-gcc + (lambda (oname objects libs parms) + (batch:system parms + "gcc" "-v" "-o" (string-append oname ".ttp") + objects libs) + (string-append oname ".ttp"))) + + (compile-c-files atari-st-turbo-c + (lambda (files parms) + (batch:system parms + "tcc" "-P" "-W-" "-Datarist" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program atari-st-turbo-c + (lambda (oname objects libs parms) + (batch:system parms + "tlink" "-o" (string-append oname ".ttp") + objects libs "mintlib.lib" "osbind.lib" + "pcstdlib.lib" "pcfltlib.lib") + (string-append oname ".ttp"))) + + (compile-c-files acorn-unixlib + (lambda (files parms) + (batch:system parms + "cc" "-c" "-depend" "!Depend" "-IUnixLib:" + "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program acorn-unixlib + (lambda (oname objects libs parms) + (batch:system parms + "link" "-o" oname objects libs + ":5.$.dev.gcc.unixlib36d.clib.o.unixlib") + (batch:system parms + "squeeze" oname) + oname)) + + (compile-c-files vms + (lambda (files parms) + (batch:system parms + "cc" + (c-includes parms) + (c-flags parms) + (replace-suffix files ".c" "")) + (replace-suffix files ".c" ".obj"))) + (link-c-program vms + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) + ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (batch:system parms + "macro" "setjump") + (batch:system parms + "link" + (apply string-join "," + (append (map (lambda (f) + (replace-suffix f ".obj" "")) + objects) + '("setjump" "sys$input/opt\n "))) + (apply string-join + "," (append (remove "" libs) + '("sys$share:vaxcrtl/share")))) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + + (compile-c-files vms-gcc + (lambda (files parms) + (batch:system parms + "gcc" + (c-includes parms) + (c-flags parms) + (replace-suffix files ".c" "")) + (replace-suffix files ".c" ".obj"))) + (link-c-program vms-gcc + (lambda (oname objects libs parms) + (let ((exe (replace-suffix (car objects) + ".obj" ".exe")) + (oexe (string-append oname ".exe"))) + (batch:system parms + "macro" "setjump") + (batch:system parms + "link" + (apply string-join "," + (append objects + '("setjump.obj" + "sys$input/opt\n "))) + (apply string-join + "," (append (remove "" libs) + '("gnu_cc:[000000]gcclib/lib" + "sys$share:vaxcrtl/share")))) + (if (not (string-ci=? exe oexe)) + (batch:rename-file parms exe oexe)) + oexe))) + + (compile-c-files *unknown* + (lambda (files parms) + (batch:system parms + "cc" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (link-c-program *unknown* + (lambda (oname objects libs parms) + (batch:rename-file parms + oname (string-append oname "~")) + (batch:system parms + "cc" "-o" oname + (must-be-first + '("-nostartfiles" + "pre-crt0.o" "ecrt0.o" + "/usr/lib/crt0.o") + (append objects libs))) + oname)) + (make-archive *unknown* + (lambda (oname objects libs parms) + (let ((aname (string-append oname ".a"))) + (batch:system parms + "ar rc" aname objects) + (batch:system parms + "ranlib" aname) + aname))) + (compile-dll-c-files *unknown* + (lambda (files parms) + (batch:system parms + "cc" "-O" "-c" + (c-includes parms) + (c-flags parms) + files) + (replace-suffix files ".c" ".o"))) + (make-dll-archive *unknown* + (lambda (oname objects libs parms) + (let ((aname (string-append oname ".a"))) + (batch:system parms + "ar rc" aname objects) + (batch:system parms + "ranlib" aname) + aname))) + (make-nothing *unknown* + (lambda (oname objects libs parms) + (if (= 1 (length objects)) (car objects) + objects))) + )) + + '(features + ((name symbol)) + ((spec expression) + (documentation string)) + ((lit () "Light - no features") + (none () "No features") + + (cautious ((define "CAUTIOUS")) + "\ +Normally, the number of arguments arguments to interpreted closures + (from LAMBDA) are checked if the function part of a form is not a +symbol or only the first time the form is executed if the function +part is a symbol. defining RECKLESS disables any checking. If you +want to have SCM always check the number of arguments to interpreted +closures #define CAUTIOUS.") + + (careful-interrupt-masking ((define "CAREFUL_INTS")) + "\ +Define CAREFUL_INTS for extra checking of interrupt masking. This is +for debugging C code in sys.c and repl.c.") + + (debug ((c-lib debug) + (features cautious careful-interrupt-masking stack-limit)) + "Debugging") + + (reckless ((define "RECKLESS")) + "\ +If your scheme code runs without any errors you can disable almost all +error checking by compiling all files with RECKLESS.") + + (stack-limit ((define ("STACK_LIMIT" "(HEAP_SEG_SIZE/2)"))) + "\ +Define STACK_LIMIT to enable checking for stack overflow. Define +value of STACK_LIMIT to be the size to which SCM should allow the +stack to grow. STACK_LIMIT should be less than the maximum size the +hardware can support, as not every routine checks the stack.") + + (bignums ((define "BIGNUMS")) + "\ +Large precision integers.") + + (arrays ((define "ARRAYS")) + "\ +Define ARRAYS if you want arrays, uniform-arrays and uniform-vectors.") + + (array-for-each ((c-file "ramap.c") (init "init_ramap")) + "\ +array-map! and array-for-each (ARRAYS must also be defined).") + + (inexact ((define "FLOATS") (c-lib m)) + "\ +Define FLOATS if you want floating point numbers.") + + (engineering-notation ((define "ENGNOT")) + "\ +Define ENGNOT if you want floats to display in engineering notation + (exponents always multiples of 3) instead of scientific notation.") + + (single-precision-only ((define "SINGLESONLY")) + "\ +Define SINGLESONLY if you want all inexact real numbers to be single +precision. This only has an effect if SINGLES is also defined (which +is the default). This does not affect complex numbers.") + + (sicp ((define "SICP")) + "\ +Define SICP if you want to run code from: + + H. Abelson, G. J. Sussman, and J. Sussman, + Structure and Interpretation of Computer Programs, + The MIT Press, Cambridge, Massachusetts, USA + + (eq? '() '#f) is the major difference.") + + (rev2-procedures ((c-file "sc2.c") (init "init_sc2")) + "\ +These procedures were specified in the `Revised^2 Report on Scheme' +but not in `R4RS'.") + + (record ((c-file "record.c") (init "init_record")) + "\ +The Record package provides a facility for user to define their own +record data types. See SLIB for documentation.") + + (compiled-closure ((define "CCLO")) + "\ +Define CCLO if you want to use compiled closures.") + + (generalized-c-arguments ((c-file "gsubr.c") (init "init_gsubr")) + "\ +make_gsubr for arbitrary (< 11) arguments to C functions.") + + (tick-interrupts ((define "TICKS")) + "\ +Define TICKS if you want the ticks and ticks-interrupt functions.") + + (i/o-extensions ((c-file "ioext.c") (init "init_ioext")) + "\ +Commonly available I/O extensions: `Exec', line I/O, file positioning, +file delete and rename, and directory functions.") + + (turtlegr + ((c-file "turtlegr.c") (c-lib graphics) (features inexact) + (init "init_turtlegr")) + "\ +`Turtle' graphics calls for both Borland-C and X11.") + + (curses ((c-file "crs.c") (c-lib curses) (init "init_crs")) + "\ +`Curses' screen management package.") + + (edit-line + ((c-file "edline.c") (c-lib termcap editline) (compiled-init "init_edline")) + "\ +interface to the editline or GNU readline library") + + (regex ((c-file "rgx.c") (c-lib regex) (init "init_rgx")) + "\ +String regular expression matching.") + + (socket ((c-file "socket.c") (init "init_socket")) + "\ +BSD socket interface.") + + (posix ((c-file "posix.c") (init "init_posix")) + "\ +Posix functions available on all `Unix-like' systems. fork and +process functions, user and group IDs, file permissions, and `link'.") + + (unix ((c-file "unix.c") (init "init_unix")) + "\ +Those unix features which have not made it into the Posix specs: nice, +acct, lstat, readlink, symlink, mknod and sync.") + + (windows ((c-lib windows)) ; (define "NON_PREEMPTIVE") + "\ +Microsoft Windows executable.") + + (dynamic-linking ((c-file "dynl.c") (c-lib dlll)) + "\ +Load compiled files while running.") + + (dump ((define "CAN_DUMP") + (c-lib dump) + (c-lib nostart) + (c-file "unexec.c") + (c-file "unexelf.c") + (c-file "gmalloc.c") + (c-file "ecrt0.c") + (c-file "pre-crt0.c")) + "\ +Convert a running scheme program into an executable file.") + +;;;; Descriptions of these parameters is in "setjump.h". +;;; (initial-heap-size ((define "INIT_HEAP_SIZE" (* 25000 sizeof-cell)))) +;;; (heap-segment-size ((define "HEAP_SEG_SIZE" (* 8100 sizeof-cell)))) +;;; (short-aligned-stack ((define "SHORT_ALIGN"))) +;;; (initial-malloc-limit ((define "INIT_MALLOC_LIMIT" 100000))) +;;; (number-of-hash-buckets ((define "NUM_HASH_BUCKETS" 137))) +;;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_size/4)"))) + + (heap-can-shrink ((define "DONT_GC_FREE_SEGMENTS")) + "\ +Define DONT_GC_FREE_SEGMENTS if you want segments of unused heap to +not be freed up after garbage collection. This may reduce time in GC +for *very* large working sets.") + + (cheap-continuations ((define "CHEAP_CONTINUATIONS")) + "\ +If you only need straight stack continuations CHEAP_CONTINUATIONS will +run faster and use less storage than not having it. Machines with +unusual stacks need this. Also, if you incorporate new C code into +scm which uses VMS system services or library routines (which need to +unwind the stack in an ordrly manner) you may need to define +CHEAP_CONTINUATIONS.") + + (memoize-local-bindings ((define "MEMOIZE_LOCALS")) + "\ +Saves the interpeter from having to look up local bindings for every +identifier reference") + )) + '(build-params + *parameter-columns* + *parameter-columns* + ((1 platform single platform + (lambda (pl) (list batch:platform)) + #f + "what to build it for") + (2 target-name single string (lambda (pl) '("scm")) #f + "base name of target") + (3 c-lib nary symbol (lambda (pl) '(c)) #f + "C library (and include files)") + (4 define nary string #f #f "#define FLAG") + (5 implinit single string + (lambda (pl) (list (object->string + (in-vicinity (implementation-vicinity) "Init.scm")))) + #f "implementation vicinity") + (6 c-file nary filename #f #f "C source files") + (7 o-file nary filename #f #f "other object files") + (8 init nary string #f #f "initialization calls") + (9 compiled-init nary string #f #f "later initialization calls") + (10 features nary symbol + (lambda (pl) '(arrays inexact bignums)) + (lambda (rdb) (((rdb 'open-table) 'features #f) 'get 'spec)) + "features to include") + (11 what single build-whats + (lambda (pl) '(exe)) + (lambda (rdb) + (define tab (((rdb 'open-table) 'build-whats #f) 'get 'class)) + (define manifest ((((rdb 'open-table) 'manifest #f) + 'row:retrieve*))) + (lambda (what) + (define catgry (tab what)) + `((c-file + ,@(map car + (remove-if-not + (lambda (row) (and (eq? 'c-source (cadr row)) + (eq? catgry (caddr row)))) + manifest))) + ,@(or ((((rdb 'open-table) 'build-whats #f) 'get 'spec) what) + '())))) + "what to build") + (12 batch-dialect single batch-dialect + guess-how + #f + "How to build") + (13 who single expression (lambda (pl) (list (current-output-port))) #f + "name of buildfile or port") + (14 compiler-options nary string #f #f "command-line compiler options") + (15 linker-options nary string #f #f "command-line linker options") + + (17 batch-port nary expression #f #f + "port batch file will be written to.") + (18 c-defines nary expression #f #f "#defines for C") + (19 c-includes nary expression #f #f "library induced defines for C") + )) + '(build-pnames + ((name string)) + ((parameter-index uint)) + ( + ("p" 1) ("platform" 1) + ("o" 2) ("outname" 2) + ("l" 3) ("libraries" 3) + ("D" 4) ("defines" 4) + ("s" 5) ("scheme initialization file" 5) + ("c" 6) ("c source files" 6) + ("j" 7) ("object files" 7) + ("i" 9) ("initialization calls" 9) + ("F" 10) ("features" 10) + ("t" 11) ("type" 11) + ("h" 12) ("batch dialect" 12) + ("w" 13) ("script name" 13) + ("compiler options" 14) + ("linker options" 15) + )) + + '(*commands* + ((name symbol)) ;or just desc:*commands* + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((build + build-params + build-pnames + build:build + "build program.") + (*initialize* + no-parameters + no-parameters + build:init + "SCM Build Database")))) + +;;;((build 'close-database)) +;;;(define build (open-database! "buildscm.scm" 'alist-table)) + +(define build:error slib:error) +(define build:c-libraries #f) +(define build:lib-cc-flag #f) +(define build:lib-ld-flag #f) +(define build:c-supress #f) +(define plan-command #f) + +;;; Look up command on a platform, but default to '*unknown* if not +;;; initially found. + +(define (make-defaulting-platform-lookup getter) + (lambda (thing plat) + (define (look platform) + (let ((ans (getter thing platform))) + (cond (ans ans) + ((eq? '*unknown* platform) + (build:error "Couldn't find: " thing)) + (else (look '*unknown*))))) + (look plat))) + +(define system:success? zero?) + +(require 'alist) +(require 'common-list-functions) +(require 'object->string) + +(define build:build + (lambda (rdb) + (lambda (parms) + (let ((expanders + (map (lambda (e) (and e (lambda (s) (e s)))) + (map (lambda (f) (if f ((slib:eval f) rdb) f)) + ((((rdb 'open-table) 'build-params #f) + 'get* 'expander)))))) + (parameter-list-expand expanders parms) + (set! parms + (fill-empty-parameters + (map slib:eval + ((((rdb 'open-table) 'build-params #f) + 'get* 'default))) + parms)) + (parameter-list-expand expanders parms)) + (let* ((platform (car (parameter-list-ref parms 'platform))) + (init= (apply string-append + (map (lambda (c) + (string-append c "();")) + (parameter-list-ref parms 'init)))) + (compiled-init= + (apply string-append + (map (lambda (c) + (string-append c "();")) + (parameter-list-ref parms 'compiled-init)))) + (c-defines + `((define "IMPLINIT" + ,(car (parameter-list-ref parms 'implinit))) + ,@(if (string=? "" init=) '() + `((define "INITS" ,init=))) + ,@(if (string=? "" compiled-init=) '() + `((define "COMPILED_INITS" ,compiled-init=))) + ,@(map (lambda (d) (if (pair? d) + `(define ,@d) + `(define ,d #t))) + (parameter-list-ref parms 'define)))) + (c-includes + (map (lambda (l) (build:lib-cc-flag l platform)) + (parameter-list-ref parms 'c-lib))) + (batch-dialect (car (parameter-list-ref parms 'batch-dialect))) + (what (car (parameter-list-ref parms 'what))) + (c-proc (plan-command ((((rdb 'open-table) 'build-whats #f) + 'get 'c-proc) + what) + platform))) + (adjoin-parameters! + parms + (cons 'c-defines c-defines) + (cons 'c-includes c-includes) + ) + + (let ((name (car (parameter-list-ref parms 'who)))) + (batch:call-with-output-script + parms + name + (lambda (batch-port) + (define o-files '()) + (adjoin-parameters! + parms + (list 'batch-port batch-port)) + + ;; ================ Write file with C defines + (apply batch:lines->file parms + "scmflags.h" + (defines->c-defines c-defines)) + + ;; ================ Compile C source files + (set! o-files + (let ((supressors + (apply append + (map (lambda (l) (build:c-supress l platform)) + (parameter-list-ref parms 'c-lib))))) + (c-proc (remove-if (lambda (file) (member file supressors)) + (parameter-list-ref parms 'c-file)) + parms))) + + ;; ================ Link C object files + ((plan-command + ((((rdb 'open-table) 'build-whats #f) 'get 'o-proc) what) + platform) + (car (parameter-list-ref parms 'target-name)) + (append o-files (parameter-list-ref parms 'o-file)) + (append + (parameter-list-ref parms 'linker-options) + (map (lambda (l) (build:lib-ld-flag l platform)) + (parameter-list-ref parms 'c-lib))) + parms)))))))) + +(define (c-defines parms) + (parameter-list-ref parms 'c-defines)) +(define (c-includes parms) + (parameter-list-ref parms 'c-includes)) +(define (c-flags parms) + (parameter-list-ref parms 'compiler-options)) + +(define (defines->c-defines defines) + (map + (lambda (d) + (case (caddr d) + ((#t) (string-join " " "#define" (cadr d))) + ((#f) (string-join " " "#undef" (cadr d))) + (else (apply string-join " " "#define" (cdr d))))) + defines)) + +(define (defines->flags defines) + (map + (lambda (d) + (case (caddr d) + ((#t) (string-append "-D" (cadr d))) + ((#f) (string-append "-U" (cadr d))) + (else (string-append "-D" (cadr d) "=" (object->string (caddr d)))))) + defines)) + +(define (guess-how pl) + (let* ((plat (parameter-list-ref pl 'platform)) + (platform (if (pair? plat) (car plat) batch:platform))) + (let ((os (or ((((build 'open-table) 'platform #f) + 'get 'operating-system) platform) batch:platform))) + (cond ((not os) (slib:error "OS corresponding to " platform " unknown")) + (else (list (os->batch-dialect os))))))) + +(define build:initializer + (lambda (rdb) + (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f)) + (set! build:lib-cc-flag + (make-defaulting-platform-lookup + (build:c-libraries 'get 'compiler-flags))) + (set! build:lib-ld-flag + (make-defaulting-platform-lookup + (build:c-libraries 'get 'link-lib-flag))) + (set! build:c-supress + (make-defaulting-platform-lookup + (build:c-libraries 'get 'supress-files))) + (set! plan-command + (let ((lookup (make-defaulting-platform-lookup + (((rdb 'open-table) 'compile-commands #f) + 'get 'procedure)))) + (lambda (thing plat) + (slib:eval (lookup thing plat))))))) +(build:initializer build) + +(define (build-from-argv argv) + (cond ((string? argv) + (require 'read-command) + (set! argv (call-with-input-string argv read-command)))) + (let () + (define command (string->symbol (list-ref argv *optind*))) + (define argc (length argv)) + (cond + ((pair? argv) + (set! *optind* (+ 1 *optind*)) + ((make-command-server build '*commands*) + command + (lambda (comname comval options positions arities types + defaults checks aliases) + (let* ((params (getopt->parameter-list + argc argv options arities types aliases)) + (fparams (fill-empty-parameters defaults params))) + (cond ((not (list? params)) #f) + ((not (check-parameters checks fparams)) #f) + ((not (check-arities (map arity->arity-spec arities) fparams)) + (slib:error 'build-from-argv "arity error" fparams) #f) + (else (comval fparams)))))))))) + +(define (build-from-whole-argv argv) + (set! *optind* 0) + (set! *optarg* #f) + (build-from-argv argv)) + +(define b build-from-whole-argv) + +(define (b*) + (require 'read-command) + (do ((e (read-command) (read-command))) + ((eof-object? e)) + (cond ((null? e)) + (else + (cond ((not (string-ci=? (car e) "build")) + (set! e (cons "build" e)))) + (write (build-from-whole-argv e)) + (newline))) + (display "build> ") + (force-output))) + +(define (bi) (build-from-argv *argv*)) + +(cond (*interactive* + (display "type (b \"build <command-line>\") to build") (newline) + (display "type (b*) to enter build command loop") (newline))) diff --git a/configure b/configure new file mode 100755 index 0000000..53d869e --- /dev/null +++ b/configure @@ -0,0 +1,849 @@ +#!/bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf. +# Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 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. + +# Usage: configure [--srcdir=DIR] [--host=HOST] [--gas] [--nfp] +# [--prefix=PREFIX] [--exec-prefix=PREFIX] [--with-PACKAGE[=VALUE]] +# Ignores all args except --srcdir, --prefix, --exec-prefix, and +# --with-PACKAGE[=VALUE] unless this script has special code to handle it. + +for arg +do + # Handle --exec-prefix with a space before the argument. + if test x$next_exec_prefix = xyes; then exec_prefix=$arg; next_exec_prefix= + # Handle --host with a space before the argument. + elif test x$next_host = xyes; then next_host= + # Handle --prefix with a space before the argument. + elif test x$next_prefix = xyes; then prefix=$arg; next_prefix= + # Handle --srcdir with a space before the argument. + elif test x$next_srcdir = xyes; then srcdir=$arg; next_srcdir= + else + case $arg in + # For backward compatibility, recognize -exec-prefix and --exec_prefix. + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* | --exe=* | --ex=* | --e=*) + exec_prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e) + next_exec_prefix=yes ;; + + -gas | --gas | --ga | --g) ;; + + -host=* | --host=* | --hos=* | --ho=* | --h=*) ;; + -host | --host | --hos | --ho | --h) + next_host=yes ;; + + -nfp | --nfp | --nf) ;; + + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + next_prefix=yes ;; + + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*) + srcdir=`echo $arg | sed 's/[-a-z_]*=//'` ;; + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s) + next_srcdir=yes ;; + + -with-* | --with-*) + package=`echo $arg|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that aren't valid shell variable names. + if test -n "`echo $package| sed 's/[-a-zA-Z0-9_]//g'`"; then + echo "configure: $package: invalid package name" >&2; exit 1 + fi + package=`echo $package| sed 's/-/_/g'` + case "$arg" in + *=*) val="`echo $arg|sed 's/[^=]*=//'`" ;; + *) val=1 ;; + esac + eval "with_$package='$val'" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb | --ver | --ve | --v) + verbose=yes ;; + + *) ;; + esac + fi +done + +trap 'rm -fr conftest* confdefs* core; exit 1' 1 3 15 +trap 'rm -f confdefs*' 0 + +# NLS nuisances. +# These must not be set unconditionally because not all systems understand +# e.g. LANG=C (notably SCO). +if test "${LC_ALL+set}" = 'set' ; then LC_ALL=C; export LC_ALL; fi +if test "${LANG+set}" = 'set' ; then LANG=C; export LANG; fi + +rm -f conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h +compile='${CC-cc} $CFLAGS conftest.c -o conftest $LIBS >/dev/null 2>&1' + +# 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. +unique_file=scl.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + srcdirdefaulted=yes + # Try the directory containing this script, then `..'. + prog=$0 + confdir=`echo $prog|sed 's%/[^/][^/]*$%%'` + test "X$confdir" = "X$prog" && confdir=. + srcdir=$confdir + if test ! -r $srcdir/$unique_file; then + srcdir=.. + fi +fi +if test ! -r $srcdir/$unique_file; then + if test x$srcdirdefaulted = xyes; then + echo "configure: Can not find sources in \`${confdir}' or \`..'." 1>&2 + else + echo "configure: Can not find sources in \`${srcdir}'." 1>&2 + fi + exit 1 +fi +# Preserve a srcdir of `.' to avoid automounter screwups with pwd. +# But we can't avoid them for `..', to make subdirectories work. +case $srcdir in + .|/*|~*) ;; + *) srcdir=`cd $srcdir; pwd` ;; # Make relative path absolute. +esac + + +# Save the original args to write them into config.status later. +configure_args="$*" + + + +test -z "$CFLAGS" && CFLAGS=-g +test -z "$LDFLAGS" && LDFLAGS=-g + +if test -z "$CC"; then + # Extract the first word of `gcc', so it can be a program name with args. + set dummy gcc; word=$2 + echo checking for $word + IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$word; then + CC="gcc" + break + fi + done + IFS="$saveifs" +fi +test -z "$CC" && CC="cc" +test -n "$CC" && test -n "$verbose" && echo " setting CC to $CC" + +# Find out if we are using GNU C, under whatever name. +cat > conftest.c <<EOF +#ifdef __GNUC__ + yes +#endif +EOF +${CC-cc} -E conftest.c > conftest.out 2>&1 +if egrep yes conftest.out >/dev/null 2>&1; then + GCC=1 # For later tests. +fi +rm -f conftest* + +# Make sure to not get the incompatible SysV /etc/install and +# /usr/sbin/install, which might be in PATH before a BSD-like install, +# or the SunOS /usr/etc/install directory, or the AIX /bin/install, +# or the AFS install, which mishandles nonexistent args, or +# /usr/ucb/install on SVR4, which tries to use the nonexistent group +# `staff'. On most BSDish systems install is in /usr/bin, not /usr/ucb +# anyway. Sigh. +if test "z${INSTALL}" = "z" ; then + echo checking for install + IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + case $dir in + /etc|/usr/sbin|/usr/etc|/usr/afsws/bin|/usr/ucb) ;; + *) + if test -f $dir/installbsd; then + INSTALL="$dir/installbsd -c" # OSF1 + INSTALL_PROGRAM='$(INSTALL)' + INSTALL_DATA='$(INSTALL) -m 644' + break + fi + if test -f $dir/install; then + if grep dspmsg $dir/install >/dev/null 2>&1; then + : # AIX + else + INSTALL="$dir/install -c" + INSTALL_PROGRAM='$(INSTALL)' + INSTALL_DATA='$(INSTALL) -m 644' + break + fi + fi + ;; + esac + done + IFS="$saveifs" +fi +INSTALL=${INSTALL-cp} +test -n "$verbose" && echo " setting INSTALL to $INSTALL" +INSTALL_PROGRAM=${INSTALL_PROGRAM-'$(INSTALL)'} +test -n "$verbose" && echo " setting INSTALL_PROGRAM to $INSTALL_PROGRAM" +INSTALL_DATA=${INSTALL_DATA-'$(INSTALL)'} +test -n "$verbose" && echo " setting INSTALL_DATA to $INSTALL_DATA" + +echo checking how to run the C preprocessor +if test -z "$CPP"; then + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and ``${CC-cc}'' will simply confuse + # make. It must be expanded now. + CPP="${CC-cc} -E" + cat > conftest.c <<EOF +#include "confdefs.h" +#include <stdio.h> +Syntax Error +EOF +err=`eval "($CPP conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + : +else + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +test ".${verbose}" != "." && echo " setting CPP to $CPP" + +if test -z "$RANLIB"; then + # Extract the first word of `ranlib', so it can be a program name with args. + set dummy ranlib; word=$2 + echo checking for $word + IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$word; then + RANLIB="ranlib" + break + fi + done + IFS="$saveifs" +fi +test -z "$RANLIB" && RANLIB=":" +test -n "$RANLIB" && test -n "$verbose" && echo " setting RANLIB to $RANLIB" + +echo checking for AIX +cat > conftest.c <<EOF +#include "confdefs.h" +#ifdef _AIX + yes +#endif + +EOF +eval "$CPP conftest.c > conftest.out 2>&1" +if egrep "yes" conftest.out >/dev/null 2>&1; then + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining _ALL_SOURCE" +echo "#define" _ALL_SOURCE 1 >> confdefs.h +DEFS="$DEFS -D_ALL_SOURCE=1" +SEDDEFS="${SEDDEFS}\${SEDdA}_ALL_SOURCE\${SEDdB}_ALL_SOURCE\${SEDdC}1\${SEDdD} +\${SEDuA}_ALL_SOURCE\${SEDuB}_ALL_SOURCE\${SEDuC}1\${SEDuD} +\${SEDeA}_ALL_SOURCE\${SEDeB}_ALL_SOURCE\${SEDeC}1\${SEDeD} +" +} + + +fi +rm -f conftest* + + +echo checking for POSIXized ISC +if test -d /etc/conf/kconfig.d && + grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 +then + ISC=1 # If later tests want to check for ISC. + +{ +test -n "$verbose" && \ +echo " defining _POSIX_SOURCE" +echo "#define" _POSIX_SOURCE 1 >> confdefs.h +DEFS="$DEFS -D_POSIX_SOURCE=1" +SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD} +\${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD} +\${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD} +" +} + + if test -n "$GCC"; then + CC="$CC -posix" + else + CC="$CC -Xp" + fi +fi + +echo checking for minix/config.h +cat > conftest.c <<EOF +#include "confdefs.h" +#include <minix/config.h> +EOF +err=`eval "($CPP conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + rm -rf conftest* + MINIX=1 + +fi +rm -f conftest* + +# The Minix shell can't assign to the same variable on the same line! +if test -n "$MINIX"; then + +{ +test -n "$verbose" && \ +echo " defining _POSIX_SOURCE" +echo "#define" _POSIX_SOURCE 1 >> confdefs.h +DEFS="$DEFS -D_POSIX_SOURCE=1" +SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD} +\${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD} +\${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD} +" +} + + +{ +test -n "$verbose" && \ +echo " defining" _POSIX_1_SOURCE to be 2 +echo "#define" _POSIX_1_SOURCE 2 >> confdefs.h +DEFS="$DEFS -D_POSIX_1_SOURCE=2" +SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_1_SOURCE\${SEDdB}_POSIX_1_SOURCE\${SEDdC}2\${SEDdD} +\${SEDuA}_POSIX_1_SOURCE\${SEDuB}_POSIX_1_SOURCE\${SEDuC}2\${SEDuD} +\${SEDeA}_POSIX_1_SOURCE\${SEDeB}_POSIX_1_SOURCE\${SEDeC}2\${SEDeD} +" +} + + +{ +test -n "$verbose" && \ +echo " defining _MINIX" +echo "#define" _MINIX 1 >> confdefs.h +DEFS="$DEFS -D_MINIX=1" +SEDDEFS="${SEDDEFS}\${SEDdA}_MINIX\${SEDdB}_MINIX\${SEDdC}1\${SEDdD} +\${SEDuA}_MINIX\${SEDuB}_MINIX\${SEDuC}1\${SEDuD} +\${SEDeA}_MINIX\${SEDeB}_MINIX\${SEDeC}1\${SEDeD} +" +} + +fi + +echo checking for ANSI C header files +cat > conftest.c <<EOF +#include "confdefs.h" +#include <stdlib.h> +#include <stdarg.h> +#include <string.h> +#include <float.h> +EOF +err=`eval "($CPP conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + rm -rf conftest* + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +echo '#include "confdefs.h" +#include <string.h>' > conftest.c +eval "$CPP conftest.c > conftest.out 2>&1" +if egrep "memchr" conftest.out >/dev/null 2>&1; then + rm -rf conftest* + # SGI's /bin/cc from Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +cat > conftest.c <<EOF +#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 +eval $compile +if test -s conftest && (./conftest; exit) 2>/dev/null; then + +{ +test -n "$verbose" && \ +echo " defining STDC_HEADERS" +echo "#define" STDC_HEADERS 1 >> confdefs.h +DEFS="$DEFS -DSTDC_HEADERS=1" +SEDDEFS="${SEDDEFS}\${SEDdA}STDC_HEADERS\${SEDdB}STDC_HEADERS\${SEDdC}1\${SEDdD} +\${SEDuA}STDC_HEADERS\${SEDuB}STDC_HEADERS\${SEDuC}1\${SEDuD} +\${SEDeA}STDC_HEADERS\${SEDeB}STDC_HEADERS\${SEDeC}1\${SEDeD} +" +} + + +fi +rm -fr conftest* + +fi +rm -f conftest* + + +fi +rm -f conftest* + +for hdr in unistd.h string.h memory.h limits.h time.h sys/types.h sys/time.h sys/timeb.h sys/times.h +do +trhdr=HAVE_`echo $hdr | tr '[a-z]./' '[A-Z]__'` +echo checking for ${hdr} +cat > conftest.c <<EOF +#include "confdefs.h" +#include <${hdr}> +EOF +err=`eval "($CPP conftest.c >/dev/null) 2>&1"` +if test -z "$err"; then + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining ${trhdr}" +echo "#define" ${trhdr} 1 >> confdefs.h +DEFS="$DEFS -D${trhdr}=1" +SEDDEFS="${SEDDEFS}\${SEDdA}${trhdr}\${SEDdB}${trhdr}\${SEDdC}1\${SEDdD} +\${SEDuA}${trhdr}\${SEDuB}${trhdr}\${SEDuC}1\${SEDuD} +\${SEDeA}${trhdr}\${SEDeB}${trhdr}\${SEDeC}1\${SEDeD} +" +} + + +fi +rm -f conftest* +done + +echo checking for whether time.h and sys/time.h may both be included +cat > conftest.c <<EOF +#include "confdefs.h" +#include <sys/types.h> +#include <sys/time.h> +#include <time.h> +int main() { exit(0); } +int t() { struct tm *tp; } +EOF +if eval $compile; then + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining TIME_WITH_SYS_TIME" +echo "#define" TIME_WITH_SYS_TIME 1 >> confdefs.h +DEFS="$DEFS -DTIME_WITH_SYS_TIME=1" +SEDDEFS="${SEDDEFS}\${SEDdA}TIME_WITH_SYS_TIME\${SEDdB}TIME_WITH_SYS_TIME\${SEDdC}1\${SEDdD} +\${SEDuA}TIME_WITH_SYS_TIME\${SEDuB}TIME_WITH_SYS_TIME\${SEDuC}1\${SEDuD} +\${SEDeA}TIME_WITH_SYS_TIME\${SEDeB}TIME_WITH_SYS_TIME\${SEDeC}1\${SEDeD} +" +} + + +fi +rm -f conftest* + +for func in ftime times +do +trfunc=HAVE_`echo $func | tr '[a-z]' '[A-Z]'` +echo checking for ${func} +cat > conftest.c <<EOF +#include "confdefs.h" +#include <ctype.h> +int main() { exit(0); } +int t() { +/* 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_${func}) || defined (__stub___${func}) +choke me +#else +/* Override any gcc2 internal prototype to avoid an error. */ +extern char ${func}(); ${func}(); +#endif + } +EOF +if eval $compile; then + rm -rf conftest* + { +test -n "$verbose" && \ +echo " defining ${trfunc}" +echo "#define" ${trfunc} 1 >> confdefs.h +DEFS="$DEFS -D${trfunc}=1" +SEDDEFS="${SEDDEFS}\${SEDdA}${trfunc}\${SEDdB}${trfunc}\${SEDdC}1\${SEDdD} +\${SEDuA}${trfunc}\${SEDuB}${trfunc}\${SEDuC}1\${SEDuD} +\${SEDeA}${trfunc}\${SEDeB}${trfunc}\${SEDeC}1\${SEDeD} +" +} + + +fi +rm -f conftest* +done + +echo checking for return type of signal handlers +cat > conftest.c <<EOF +#include "confdefs.h" +#include <sys/types.h> +#include <signal.h> +#ifdef signal +#undef signal +#endif +extern void (*signal ()) (); +int main() { exit(0); } +int t() { int i; } +EOF +if eval $compile; then + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining" RETSIGTYPE to be void +echo "#define" RETSIGTYPE void >> confdefs.h +DEFS="$DEFS -DRETSIGTYPE=void" +SEDDEFS="${SEDDEFS}\${SEDdA}RETSIGTYPE\${SEDdB}RETSIGTYPE\${SEDdC}void\${SEDdD} +\${SEDuA}RETSIGTYPE\${SEDuB}RETSIGTYPE\${SEDuC}void\${SEDuD} +\${SEDeA}RETSIGTYPE\${SEDeB}RETSIGTYPE\${SEDeC}void\${SEDeD} +" +} + + +else + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining" RETSIGTYPE to be int +echo "#define" RETSIGTYPE int >> confdefs.h +DEFS="$DEFS -DRETSIGTYPE=int" +SEDDEFS="${SEDDEFS}\${SEDdA}RETSIGTYPE\${SEDdB}RETSIGTYPE\${SEDdC}int\${SEDdD} +\${SEDuA}RETSIGTYPE\${SEDuB}RETSIGTYPE\${SEDuC}int\${SEDuD} +\${SEDeA}RETSIGTYPE\${SEDeB}RETSIGTYPE\${SEDeC}int\${SEDeD} +" +} + +fi +rm -f conftest* + + +prog='/* 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; +/* 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; +}' +echo checking for lack of working const +cat > conftest.c <<EOF +#include "confdefs.h" + +int main() { exit(0); } +int t() { $prog } +EOF +if eval $compile; then + : +else + rm -rf conftest* + +{ +test -n "$verbose" && \ +echo " defining" const to be empty +echo "#define" const >> confdefs.h +DEFS="$DEFS -Dconst=" +SEDDEFS="${SEDDEFS}\${SEDdA}const\${SEDdB}const\${SEDdC}\${SEDdD} +\${SEDuA}const\${SEDuB}const\${SEDuC}\${SEDuD} +\${SEDeA}const\${SEDeB}const\${SEDeC}\${SEDeD} +" +} + +fi +rm -f conftest* + +echo checking whether $CC and cc understand -c and -o together +echo 'foo(){}' > conftest.c +# Make sure it works both with $CC and with simple cc. +# We do the test twice because some compilers refuse to overwrite an +# existing .o file with -o, though they will create one. +if ${CC-cc} -c conftest.c -o conftest.o >/dev/null 2>&1 \ + && test -f conftest.o && ${CC-cc} -c conftest.c -o conftest.o >/dev/null 2>&1 +then + # Test first that cc exists at all. + if cc -c conftest.c >/dev/null 2>&1 + then + if cc -c conftest.c -o conftest2.o >/dev/null 2>&1 && \ + test -f conftest2.o && cc -c conftest.c -o conftest2.o >/dev/null 2>&1 + then + : + else + +{ +test -n "$verbose" && \ +echo " defining NO_MINUS_C_MINUS_O" +echo "#define" NO_MINUS_C_MINUS_O 1 >> confdefs.h +DEFS="$DEFS -DNO_MINUS_C_MINUS_O=1" +SEDDEFS="${SEDDEFS}\${SEDdA}NO_MINUS_C_MINUS_O\${SEDdB}NO_MINUS_C_MINUS_O\${SEDdC}1\${SEDdD} +\${SEDuA}NO_MINUS_C_MINUS_O\${SEDuB}NO_MINUS_C_MINUS_O\${SEDuC}1\${SEDuD} +\${SEDeA}NO_MINUS_C_MINUS_O\${SEDeB}NO_MINUS_C_MINUS_O\${SEDeC}1\${SEDeD} +" +} + + fi + fi +else + +{ +test -n "$verbose" && \ +echo " defining NO_MINUS_C_MINUS_O" +echo "#define" NO_MINUS_C_MINUS_O 1 >> confdefs.h +DEFS="$DEFS -DNO_MINUS_C_MINUS_O=1" +SEDDEFS="${SEDDEFS}\${SEDdA}NO_MINUS_C_MINUS_O\${SEDdB}NO_MINUS_C_MINUS_O\${SEDdC}1\${SEDdD} +\${SEDuA}NO_MINUS_C_MINUS_O\${SEDuB}NO_MINUS_C_MINUS_O\${SEDuC}1\${SEDuD} +\${SEDeA}NO_MINUS_C_MINUS_O\${SEDeB}NO_MINUS_C_MINUS_O\${SEDeC}1\${SEDeD} +" +} + +fi +rm -f conftest* + + + + +# Set default prefixes. +if test -n "$prefix"; then + test -z "$exec_prefix" && exec_prefix='${prefix}' + prsub="s%^prefix\\([ ]*\\)=\\([ ]*\\).*$%prefix\\1=\\2$prefix%" +fi +if test -n "$exec_prefix"; then + prsub="$prsub +s%^exec_prefix\\([ ]*\\)=\\([ ]*\\).*$%exec_prefix\\1=\\2$exec_prefix%" +fi +# Quote sed substitution magic chars in DEFS. +cat >conftest.def <<EOF +$DEFS +EOF +escape_ampersand_and_backslash='s%[&\\]%\\&%g' +DEFS=`sed "$escape_ampersand_and_backslash" <conftest.def` +rm -f conftest.def +# Substitute for predefined variables. + +trap 'rm -f config.status; exit 1' 1 3 15 +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 $configure_args + +for arg +do + case "\$arg" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo running \${CONFIG_SHELL-/bin/sh} $0 $configure_args + exec \${CONFIG_SHELL-/bin/sh} $0 $configure_args ;; + *) echo "Usage: config.status --recheck" 2>&1; exit 1 ;; + esac +done + +trap 'rm -fr Makefile scmconfig.h conftest*; exit 1' 1 3 15 +CFLAGS='$CFLAGS' +LDFLAGS='$LDFLAGS' +CC='$CC' +INSTALL='$INSTALL' +INSTALL_PROGRAM='$INSTALL_PROGRAM' +INSTALL_DATA='$INSTALL_DATA' +CPP='$CPP' +RANLIB='$RANLIB' +LIBOBJS='$LIBOBJS' +LIBS='$LIBS' +srcdir='$srcdir' +prefix='$prefix' +exec_prefix='$exec_prefix' +prsub='$prsub' +extrasub='$extrasub' +EOF +cat >> config.status <<\EOF + +top_srcdir=$srcdir + +CONFIG_FILES=${CONFIG_FILES-"Makefile"} +for file in .. ${CONFIG_FILES}; do if test "x$file" != x..; then + srcdir=$top_srcdir + # Remove last slash and all that follows it. Not all systems have dirname. + dir=`echo $file|sed 's%/[^/][^/]*$%%'` + if test "$dir" != "$file"; then + test "$top_srcdir" != . && srcdir=$top_srcdir/$dir + test ! -d $dir && mkdir $dir + fi + echo creating $file + rm -f $file + echo "# Generated automatically from `echo $file|sed 's|.*/||'`.in by configure." > $file + sed -e " +$prsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@CC@%$CC%g +s%@INSTALL@%$INSTALL%g +s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%g +s%@CPP@%$CPP%g +s%@RANLIB@%$RANLIB%g +s%@LIBOBJS@%$LIBOBJS%g +s%@LIBS@%$LIBS%g +s%@srcdir@%$srcdir%g +s%@DEFS@%-DHAVE_CONFIG_H%" $top_srcdir/${file}.in >> $file +fi; done + +CONFIG_HEADERS=${CONFIG_HEADERS-"scmconfig.h"} +for file in .. ${CONFIG_HEADERS}; do if test "x$file" != x..; then +echo creating $file + +# These sed commands are put into SEDDEFS when defining a macro. +# They are broken into pieces to make the sed script easier to manage. +# They 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. +# Each defining turns into a single global substitution command. +# +# SEDd sets the value in "#define NAME VALUE" lines. +SEDdA='s@^\([ ]*\)#\([ ]*define[ ][ ]*\)' +SEDdB='\([ ][ ]*\)[^ ]*@\1#\2' +SEDdC='\3' +SEDdD='@g' +# SEDu turns "#undef NAME" with trailing blanks into "#define NAME VALUE". +SEDuA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +SEDuB='\([ ]\)@\1#\2define\3' +SEDuC=' ' +SEDuD='\4@g' +# SEDe turns "#undef NAME" without trailing blanks into "#define NAME VALUE". +SEDeA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +SEDeB='$@\1#\2define\3' +SEDeC=' ' +SEDeD='@g' +rm -f conftest.sed +EOF +# Turn off quoting long enough to insert the sed commands. +rm -f conftest.sh +cat > conftest.sh <<EOF +$SEDDEFS +EOF + +# Break up $SEDDEFS (now in conftest.sh) because some shells have a limit +# on the size of here documents. + +# Maximum number of lines to put in a single here document. +maxshlines=9 + +while : +do + # wc gives bogus results for an empty file on some systems. + lines=`grep -c . conftest.sh` + if test -z "$lines" || test "$lines" -eq 0; then break; fi + rm -f conftest.s1 conftest.s2 + sed ${maxshlines}q conftest.sh > conftest.s1 # Like head -20. + sed 1,${maxshlines}d conftest.sh > conftest.s2 # Like tail +21. + # Write a limited-size here document to append to conftest.sed. + echo 'cat >> conftest.sed <<CONFEOF' >> config.status + cat conftest.s1 >> config.status + echo 'CONFEOF' >> config.status + rm -f conftest.s1 conftest.sh + mv conftest.s2 conftest.sh +done +rm -f conftest.sh + +# Now back to your regularly scheduled config.status. +cat >> config.status <<\EOF +# This sed command replaces #undef's 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 in +# scmconfig.h. +cat >> conftest.sed <<\CONFEOF +s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */, +CONFEOF +rm -f conftest.h +# Break up the sed commands because old seds have small limits. +maxsedlines=20 +cp $top_srcdir/$file.in conftest.h1 +while : +do + lines=`grep -c . conftest.sed` + if test -z "$lines" || test "$lines" -eq 0; then break; fi + rm -f conftest.s1 conftest.s2 conftest.h2 + sed ${maxsedlines}q conftest.sed > conftest.s1 # Like head -20. + sed 1,${maxsedlines}d conftest.sed > conftest.s2 # Like tail +21. + sed -f conftest.s1 < conftest.h1 > conftest.h2 + rm -f conftest.s1 conftest.h1 conftest.sed + mv conftest.h2 conftest.h1 + mv conftest.s2 conftest.sed +done +rm -f conftest.sed conftest.h +echo "/* $file. Generated automatically by configure. */" > conftest.h +cat conftest.h1 >> conftest.h +rm -f conftest.h1 +if cmp -s $file conftest.h 2>/dev/null; then + # The file exists and we would not be changing it. + echo "$file is unchanged" + rm -f conftest.h +else + rm -f $file + mv conftest.h $file +fi +fi; done + + + +exit 0 +EOF +chmod +x config.status +${CONFIG_SHELL-/bin/sh} config.status + + diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..76c60ad --- /dev/null +++ b/configure.in @@ -0,0 +1,33 @@ +dnl Process this file with autoconf to produce a configure script. +AC_INIT(scl.c) +AC_CONFIG_HEADER(scmconfig.h) + +test -z "$CFLAGS" && CFLAGS=-g AC_SUBST(CFLAGS) +test -z "$LDFLAGS" && LDFLAGS=-g AC_SUBST(LDFLAGS) + +AC_PROG_CC +AC_PROG_INSTALL +AC_PROG_CPP +AC_PROG_RANLIB +AC_AIX +AC_ISC_POSIX +AC_MINIX +AC_STDC_HEADERS +AC_HAVE_HEADERS(unistd.h string.h memory.h limits.h time.h sys/types.h sys/time.h sys/timeb.h sys/times.h) +AC_TIME_WITH_SYS_TIME +AC_HAVE_FUNCS(ftime times getcwd) +AC_RETSIGTYPE +AC_CONST +AC_MINUS_C_MINUS_O +dnl AC_PREFIX(scm) + +AC_SUBST(LIBOBJS) + +AC_OUTPUT(Makefile) + +dnl Local Variables: +dnl comment-start: "dnl " +dnl comment-end: "" +dnl comment-start-skip: "\\bdnl\\b\\s *" +dnl compile-command: "make configure scmconfig.h.in" +dnl End: diff --git a/continue.c b/continue.c new file mode 100644 index 0000000..b28fe6e --- /dev/null +++ b/continue.c @@ -0,0 +1,255 @@ +/* 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. + */ + +/* "continue.c" Scheme Continuations for C. + Author: Aubrey Jaffer */ + +/* "setjump.h" contains definitions for the `other' field (type + CONTINUATION_OTHER) the struct Continuation. "setjump.h" must + #include "continue.h". CONTINUATION_OTHER defaults to `long' */ + +#define IN_CONTINUE_C +#ifdef USE_CONTINUE_H +# include "continue.h" +#else +# include "setjump.h" +#endif + +/* For platforms with short integers, we use thrown_value instead of + the value returned from setjmp so that any (long) value can be + returned. */ + +#ifdef SHORT_INT +long thrown_value; +#endif + +/* stack_size() returns the number of units of size STACKITEM which + fit between @var{start} and the current top of stack. No check is + done in this routine to ensure that @var{start} is actually in the + current stack segment. */ + +long stack_size(start) + STACKITEM *start; +{ + STACKITEM stack; +#ifdef STACK_GROWS_UP + return &stack - start; +#else + return start - &stack; +#endif /* def STACK_GROWS_UP */ +} + +/* make_root_continuation() allocates (malloc) storage for a + CONTINUATION near the current extent of stack. This newly + allocated CONTINUATION is returned if successful, 0 if not. After + make_root_continuation() returns, the calling routine still needs + to `setjmp(new_continuation->jmpbuf)' in order to complete the + capture of this continuation. */ + +CONTINUATION *make_root_continuation(stack_base) + STACKITEM *stack_base; +{ + CONTINUATION *cont; + cont = (CONTINUATION *)malloc(sizeof(CONTINUATION)); + if (!cont) return 0; + cont->length = 0; + cont->stkbse = stack_base; + cont->parent = cont; + return cont; +} + +/* make_continuation() allocates storage for the current continuation, + copying (or encapsulating) the stack state from parent_cont->stkbse + to the current top of stack. The newly allocated CONTINUATION is + returned if successful, 0 if not. After make_continuation() + returns, the calling routine still needs to + `setjmp(new_continuation->jmpbuf)' in order to complete the capture + of this continuation. */ + +/* Note: allocating local (stack) storage for the CONTINUATION would + not work; Think about it. */ + +CONTINUATION *make_continuation(parent_cont) + CONTINUATION *parent_cont; +{ + CONTINUATION *cont; +#ifdef CHEAP_CONTINUATIONS + cont = (CONTINUATION *)malloc(sizeof(CONTINUATION)); + if (!cont) return 0; + cont->length = 0; + cont->stkbse = parent_cont->stkbse; +#else + long j; + register STACKITEM *src, *dst; + FLUSH_REGISTER_WINDOWS; + j = stack_size(parent_cont->stkbse); + cont = (CONTINUATION *)malloc((sizeof(CONTINUATION) + j*sizeof(STACKITEM))); + if (!cont) return 0; + cont->length = j; + cont->stkbse = parent_cont->stkbse; + src = cont->stkbse; +# ifdef STACK_GROWS_UP + src += parent_cont->length; +# else + src -= parent_cont->length + cont->length; +# endif/* ndef STACK_GROWS_UP */ + dst = (STACKITEM *)(cont + 1); + for (j = cont->length; 0 <= --j; ) *dst++ = *src++; +#endif /* ndef CHEAP_CONTINUATIONS */ + cont->parent = parent_cont; + return cont; +} + +/* free_continuation() is trivial, but who knows what the future + holds. */ + +void free_continuation(cont) + CONTINUATION *cont; +{ + free(cont); +} + +/* Final routine involved in throw()ing to a continuation. After + ensuring that there is sufficient room on the stack for the saved + continuation, dynthrow() copies the continuation onto the stack and + longjmp()s into it. The routine does not return. */ + +/* If you use conservative GC and your Sparc(SUN-4) heap is growing + out of control: + + You are experiencing a GC problem peculiar to the Sparc. The + problem is that contin doesn't know how to clear register windows. + Every location which is not reused still gets marked at GC time. + This causes lots of stuff which should be collected to not be. + This will be a problem with any *conservative* GC until we find + what instruction will clear the register windows. This problem is + exacerbated by using lots of make-CONTINUATION. + + Possibly adding the following before the thrown_value = val; line + might help to clear out unused stack above the continuation (a + small part of the problem). + +#ifdef sparc + bzero((void *)&a, sizeof(STACKITEM) * + (((STACKITEM *)&a) - (dst - cont->length))) +#endif + + Let me know if you try it. */ + +void dynthrow(a) + long *a; +{ + register CONTINUATION *cont = (CONTINUATION *)(a[0]); + long val = a[1]; +#ifndef CHEAP_CONTINUATIONS + register long j; + register STACKITEM *src, *dst = cont->stkbse; +# ifdef STACK_GROWS_UP + if (a[2] && (a - ((long *)a[3]) < 100)) + puts("grow_throw: check if long growth[100]; being optimized out"); + /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */ + if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a); +# else + if (a[2] && (((long *)a[3]) - a < 100)) + puts("grow_throw: check if long growth[100]; being optimized out"); + /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */ + dst -= cont->length; + if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a); +# endif/* def STACK_GROWS_UP */ + FLUSH_REGISTER_WINDOWS; + src = (STACKITEM *)(cont + 1); + for (j = cont->length;0 <= --j;) *dst++ = *src++; +#endif /* ndef CHEAP_CONTINUATIONS */ +#ifdef SHORT_INT + thrown_value = val; + longjmp(cont->jmpbuf, 1); +#else + longjmp(cont->jmpbuf, val); +#endif +} + +/* grow_throw() grows the stack by 100 long words. If the "sizeof + growth" assignment is not sufficient to restrain your overly + optimistic compiler, the stack will grow by much less and + grow_throw() and dynthrow() will waste time calling each other. To + fix this you will have to compile grow_throw() in a separate file + so the compiler won't be able to guess that the growth array isn't + all used. */ + +#ifndef CHEAP_CONTINUATIONS +void grow_throw(a) /* Grow the stack so that there is room */ + long *a; /* to copy in the continuation. Then */ +{ /* retry the throw. */ + long growth[100]; + growth[0] = a[0]; + growth[1] = a[1]; + growth[2] = a[2] + 1; + growth[3] = (long) a; + growth[99] = sizeof growth; + dynthrow(growth); +} +#endif /* ndef CHEAP_CONTINUATIONS */ + +/* throw_to_continuation() restores the stack in effect when + @var{cont} was made and resumes @var{cont}'s processor state. If + the stack cannot be resotred because @var{cont} and @var{root_cont} + do not have the same stkbase, @code{throw_to_continuation() + returns. */ + +/* Note: If 2 or more @var{cont}s share a parent continuation and if + the values of stack allocated variables in that parent continuation + are changed, the results are unspecified. This is because the + parent continuation may or may not be reloaded, depending on what + other throws have intervened. */ + +void throw_to_continuation(cont, val, root_cont) + CONTINUATION *cont; + long val; + CONTINUATION *root_cont; +{ + long a[3]; + a[0] = (long)cont; + a[1] = val; + a[2] = 0; + if (cont->stkbse != root_cont->stkbse) + return; /* Stale continuation */ + dynthrow(a); +} diff --git a/continue.h b/continue.h new file mode 100644 index 0000000..3309172 --- /dev/null +++ b/continue.h @@ -0,0 +1,178 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "continue.h" Scheme Continuations for C. + Author: Aubrey Jaffer. */ + +#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 */ + +/* `other' is a CONTINUATION slot for miscellaneous data of type + CONTINUATION_OTHER. */ + +#ifndef CONTINUATION_OTHER +# define CONTINUATION_OTHER int +#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 STACKITEM; +#else +typedef long STACKITEM; +#endif + +struct Continuation {jmp_buf jmpbuf; + long thrwval; + long length; + STACKITEM *stkbse; + CONTINUATION_OTHER other; + struct Continuation *parent; + }; +typedef struct Continuation CONTINUATION; + +#ifndef P +# ifdef USE_ANSI_PROTOTYPES +# define P(s) s +# else +# define P(s) () +# endif +#endif + +extern long thrown_value; +long stack_size P((STACKITEM *start)); +CONTINUATION *make_root_continuation P((STACKITEM *stack_base)); +CONTINUATION *make_continuation P((CONTINUATION *parent_cont)); +void free_continuation P((CONTINUATION *cont)); +void dynthrow P((long *a)); +void grow_throw P((long *a)); +void throw_to_continuation P((CONTINUATION *cont, long val, + CONTINUATION *root_cont)); + +/* how to get the local definition for malloc */ + +#ifndef STDC_HEADERS +# ifndef malloc + char *malloc P((sizet size)); +# endif + char *realloc P((char *ptr, sizet size)); +#endif + +/* PTR_LT defines how to compare two addresses (which may not be in + the same array). */ + +#if defined(__TURBOC__) && !defined(__TOS__) +# ifdef PROT386 +# define PTR_LT(x, y) (((long)(x)) < ((long)(y))) +# else +# define PTR_LT(x, y) ((x) < (y)) +# endif +#else /* not __TURBOC__ */ +# ifdef nosve +# define PTR_MASK 0xffffffffffff +# define PTR_LT(x, y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK)) +# else +# define PTR_LT(x, y) ((x) < (y)) +# endif +#endif + +#define PTR_GT(x, y) PTR_LT(y, x) +#define PTR_LE(x, y) (!PTR_GT(x, y)) +#define PTR_GE(x, y) (!PTR_LT(x, y)) + +/* 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 FLUSH_REGISTER_WINDOWS asm("ta 3") +#else +# define FLUSH_REGISTER_WINDOWS /* empty */ +#endif + +/* If stacks grow up then */ + +/* #define STACK_GROWS_UP */ +#ifdef hp9000s800 +# define STACK_GROWS_UP +#endif +#ifdef pyr +# define STACK_GROWS_UP +#endif +#ifdef nosve +# define STACK_GROWS_UP +#endif +#ifdef _UNICOS +# define STACK_GROWS_UP +#endif @@ -0,0 +1,412 @@ +/* Copyright (C) 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. + */ + +/* "crs.c" interface to `curses' interactive terminal control library. + Author: Aubrey Jaffer */ + +#include "scm.h" +#include <curses.h> + +#ifdef MWC +# include <unctrl.h> +#endif + +#ifndef STDC_HEADERS + int wrefresh P((WINDOW *)); + int wgetch P((WINDOW *)); +#endif + +/* define WIN port type */ +#define WIN(obj) ((WINDOW*)CDR(obj)) +#define WINP(obj) (tc16_window==TYP16(obj)) +int freewindow(win) + WINDOW *win; +{ + if (win==stdscr) return 0; + delwin(win); + return 0; +} +int prinwindow(exp, port, writing) + SCM exp; SCM port; int writing; +{ + prinport(exp, port, "window"); + return !0; +} +int bwaddch(c, win) int c; WINDOW *win; {waddch(win, c);return c;} +int bwaddstr(str, win) char *str; WINDOW *win; {waddstr(win, str);return 0;} +sizet bwwrite(str, siz, num, win) + sizet siz, num; + char *str; WINDOW *win; +{ + sizet i = 0, prod = siz*num; + for (;i < prod;i++) waddch(win, str[i]); + return num; +} +int tc16_window; +static ptobfuns winptob = { + mark0, + freewindow, + prinwindow, + equal0, + bwaddch, + bwaddstr, + bwwrite, + wrefresh, + wgetch, + freewindow}; + +SCM mkwindow(win) + WINDOW *win; +{ + SCM z; + if (NULL==win) return BOOL_F; + NEWCELL(z); + DEFER_INTS; + SETCHARS(z, win); + CAR(z) = tc16_window | OPN | RDNG | WRTNG; + ALLOW_INTS; + return z; +} + +SCM *loc_stdscr = 0; +SCM linitscr() +{ + WINDOW *win; + if NIMP(*loc_stdscr) { + refresh(); + return *loc_stdscr; + } + win = initscr(); + return *loc_stdscr = mkwindow(win); +} +SCM lendwin() +{ + if IMP(*loc_stdscr) return BOOL_F; + return ERR==endwin() ? BOOL_F : BOOL_T; +} + +static char s_newwin[] = "newwin", s_subwin[] = "subwin", s_mvwin[] = "mvwin", + s_overlay[] = "overlay", s_overwrite[] = "overwrite"; +SCM lnewwin(lines, cols, args) + SCM lines, cols, args; +{ + SCM begin_y, begin_x; + WINDOW *win; + ASSERT(INUMP(lines), lines, ARG1, s_newwin); + ASSERT(INUMP(cols), cols, ARG2, s_newwin); + ASSERT(2==ilength(args), args, WNA, s_newwin); + begin_y = CAR(args); + begin_x = CAR(CDR(args)); + ASSERT(INUMP(begin_y), begin_y, ARG3, s_newwin); + ASSERT(INUMP(begin_x), begin_y, ARG4, s_newwin); + win = newwin(INUM(lines), INUM(cols), + INUM(begin_y), INUM(begin_x)); + return mkwindow(win); +} + +SCM lmvwin(win, y, x) + SCM win, y, x; +{ + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_mvwin); + ASSERT(INUMP(x), x, ARG2, s_mvwin); + ASSERT(INUMP(y), y, ARG3, s_mvwin); + return ERR==mvwin(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T; +} + +SCM lsubwin(win, lines, args) + SCM win, lines, args; +{ + SCM cols, begin_y, begin_x; + WINDOW *nwin; + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_subwin); + ASSERT(INUMP(lines), lines, ARG2, s_subwin); + ASSERT(3==ilength(args), args, WNA, s_subwin); + cols = CAR(args); + args = CDR(args); + begin_y = CAR(args); + begin_x = CAR(CDR(args)); + ASSERT(INUMP(cols), cols, ARG3, s_subwin); + ASSERT(INUMP(begin_y), begin_y, ARG3, s_subwin); + ASSERT(INUMP(begin_x), begin_y, ARG4, s_subwin); + nwin = subwin(WIN(win), INUM(lines), INUM(cols), + INUM(begin_y), INUM(begin_x)); + return mkwindow(nwin); +} + +SCM loverlay(srcwin, dstwin) + SCM srcwin, dstwin; +{ + ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overlay); + ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overlay); + return ERR==overlay(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T; +} + +SCM loverwrite(srcwin, dstwin) + SCM srcwin, dstwin; +{ + ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overwrite); + ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overwrite); + return ERR==overwrite(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T; +} + +static char s_wmove[] = "wmove", s_wadd[] = "wadd", s_winsert[] = "winsert", + s_box[] = "box"; +SCM lwmove(win, y, x) + SCM win, y, x; +{ + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wmove); + ASSERT(INUMP(x), x, ARG2, s_wmove); + ASSERT(INUMP(y), y, ARG3, s_wmove); + return ERR==wmove(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T; +} + +SCM lwadd(win, obj) + SCM win, obj; +{ + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wadd); + if ICHRP(obj) + return ERR==waddch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T; + if INUMP(obj) + return ERR==waddch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T; + ASSERT(NIMP(obj) && STRINGP(obj), obj, ARG2, s_wadd); + return ERR==waddstr(WIN(win), CHARS(obj)) ? BOOL_F : BOOL_T; +} + +SCM lwinsert(win, obj) + SCM win, obj; +{ + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winsert); + if INUMP(obj) + return ERR==winsch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T; + ASSERT(ICHRP(obj), obj, ARG2, s_winsert); + return ERR==winsch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T; +} + +SCM lbox(win, vertch, horch) + SCM win, vertch, horch; +{ + int v, h; + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_box); + if INUMP(vertch) v = INUM(vertch); + else { + ASSERT(ICHRP(vertch), vertch, ARG2, s_box); + v = ICHR(vertch); + } + if INUMP(horch) h = INUM(horch); + else { + ASSERT(ICHRP(horch), horch, ARG3, s_box); + h = ICHR(horch); + } + return ERR==box(WIN(win), v, h) ? BOOL_F : BOOL_T; +} + +static char s_getyx[] = "getyx", s_winch[] = "winch", s_unctrl[] = "unctrl"; +SCM lgetyx(win) + SCM win; +{ + int y, x; + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_getyx); + getyx(WIN(win), y, x); + return cons2(MAKINUM(y), MAKINUM(x), EOL); +} + +SCM lwinch(win) + SCM win; +{ + ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winch); + return MAKICHR(winch(WIN(win))); +} + +SCM lunctrl(c) + SCM c; +{ + ASSERT(ICHRP(c), c, ARG1, s_unctrl); + { + char *str = unctrl(ICHR(c)); + return makfrom0str(str); + } +} +static char s_owidth[] = "output-port-width"; +static char s_oheight[] = "output-port-height"; +SCM owidth(arg) + SCM arg; +{ + if UNBNDP(arg) arg = cur_outp; + ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth); + if NIMP(*loc_stdscr) + if WINP(arg) return MAKINUM(WIN(arg)->_maxx+1); + else return MAKINUM(COLS); + return MAKINUM(80); +} +SCM oheight(arg) + SCM arg; +{ + if UNBNDP(arg) arg = cur_outp; + ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth); + if NIMP(*loc_stdscr) + if WINP(arg) return MAKINUM(WIN(arg)->_maxy+1); + else return MAKINUM(LINES); + return MAKINUM(24); +} +SCM lrefresh() +{ + return MAKINUM(wrefresh(curscr)); +} + +#define SUBR0(lname, name) SCM lname(){name();return UNSPECIFIED;} +SUBR0(lnl, nl) +SUBR0(lnonl, nonl) +SUBR0(lcbreak, cbreak) +SUBR0(lnocbreak, nocbreak) +SUBR0(lecho, echo) +SUBR0(lnoecho, noecho) +SUBR0(lraw, raw) +SUBR0(lnoraw, noraw) +SUBR0(lsavetty, savetty) +SUBR0(lresetty, resetty) + +static char s_nonl[] = "nonl", s_nocbreak[] = "nocbreak", + s_noecho[] = "noecho", s_noraw[] = "noraw"; + +static iproc subr0s[] = { + {"initscr", linitscr}, + {"endwin", lendwin}, + {&s_nonl[2], lnl}, + {s_nonl, lnonl}, + {&s_nocbreak[2], lcbreak}, + {s_nocbreak, lnocbreak}, + {&s_noecho[2], lecho}, + {s_noecho, lnoecho}, + {&s_noraw[2], lraw}, + {s_noraw, lnoraw}, + {"resetty", lresetty}, + {"savetty", lsavetty}, + {"refresh", lrefresh}, + {0, 0}}; + +#define SUBRW(ln, n, s_n, sn) static char s_n[]=sn;\ + SCM ln(w)SCM w;\ + {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\ + return ERR==n(WIN(w))?BOOL_F:BOOL_T;} + +SUBRW(lwerase, werase, s_werase, "werase") +SUBRW(lwclear, wclear, s_wclear, "wclear") +SUBRW(lwclrtobot, wclrtobot, s_wclrtobot, "wclrtobot") +SUBRW(lwclrtoeol, wclrtoeol, s_wclrtoeol, "wclrtoeol") +SUBRW(lwdelch, wdelch, s_wdelch, "wdelch") +SUBRW(lwdeleteln, wdeleteln, s_wdeleteln, "wdeleteln") +SUBRW(lwinsertln, winsertln, s_winsertln, "winsertln") +SUBRW(lscroll, scroll, s_scroll, "scroll") +SUBRW(ltouchwin, touchwin, s_touchwin, "touchwin") +SUBRW(lwstandout, wstandout, s_wstandout, "wstandout") +SUBRW(lwstandend, wstandend, s_wstandend, "wstandend") + +static iproc subr1s[] = { + {s_werase, lwerase}, + {s_wclear, lwclear}, + {s_wclrtobot, lwclrtobot}, + {s_wclrtoeol, lwclrtoeol}, + {s_wdelch, lwdelch}, + {s_wdeleteln, lwdeleteln}, + {s_winsertln, lwinsertln}, + {s_scroll, lscroll}, + {s_touchwin, ltouchwin}, + {s_wstandout, lwstandout}, + {s_wstandend, lwstandend}, + {s_getyx, lgetyx}, + {s_winch, lwinch}, + {s_unctrl, lunctrl}, + {0, 0}}; + +#define SUBROPT(ln, n, s_n, sn) static char s_n[]=sn;\ + SCM ln(w, b)SCM w, b;\ + {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\ + return ERR==n(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;} + +/* SUBROPT(lclearok, clearok, s_clearok, "clearok") */ +/* SUBROPT(lidlok, idlok, s_idlok, "idlok") */ +SUBROPT(lleaveok, leaveok, s_leaveok, "leaveok") +SUBROPT(lscrollok, scrollok, s_scrollok, "scrollok") +/* SUBROPT(lnodelay, nodelay, s_nodelay, "nodelay") */ + +static char s_clearok[] = "clearok"; +SCM lclearok(w, b) SCM w, b; +{ + if (BOOL_T==w) return ERR==clearok(curscr, BOOL_F != b)?BOOL_F:BOOL_T; + ASSERT(NIMP(w) && WINP(w), w, ARG1, s_clearok); + return ERR==clearok(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T; +} + +static iproc subr2s[] = { + {s_overlay, loverlay}, + {s_overwrite, loverwrite}, + {s_wadd, lwadd}, + {s_winsert, lwinsert}, + {s_clearok, lclearok}, + /* {s_idlok, lidlok}, */ + {s_leaveok, lleaveok}, + {s_scrollok, lscrollok}, +/* {s_nodelay, lnodelay}, */ + {0, 0}}; + +void init_crs() +{ + /* savetty(); */ + /* "Stdscr" is a nearly inaccessible symbol used as a GC protect. */ + loc_stdscr = &CDR(sysintern("Stdscr", UNDEFINED)); + tc16_window = newptob(&winptob); + + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); + + make_subr(s_owidth, tc7_subr_1o, owidth); + make_subr(s_oheight, tc7_subr_1o, oheight); + + make_subr(s_newwin, tc7_lsubr_2, lnewwin); + make_subr(s_subwin, tc7_lsubr_2, lsubwin); + + make_subr(s_wmove, tc7_subr_3, lwmove); + make_subr(s_mvwin, tc7_subr_3, lmvwin); + make_subr(s_box, tc7_subr_3, lbox); + add_feature("curses"); + add_final(lendwin); +} @@ -0,0 +1,448 @@ +/* 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 */ + +#include "scm.h" +#ifndef STDC_HEADERS + int free (); /* P((char *ptr)) */ +#endif + +/* linkpath holds the filename which just got linked. Scheme + *loadpath* will get set to linkpath and then restored around the + initialization call */ +/* static SCM linkpath; */ + +#ifdef DLD +# include "dld.h" + +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); +} + +static char s_link[] = "dyn:link", s_call[] = "dyn:call"; +SCM l_dyn_link(fname) + SCM fname; +{ + int status; + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link); + DEFER_INTS; + status = dld_link(CHARS(fname)); + ALLOW_INTS; + if (!status) {/* linkpath = fname; */ return fname;} + if (DLD_ENOFILE==status) return BOOL_F; + if (DLD_EBADOBJECT==status) return BOOL_F; + dld_perror("DLD"); + return BOOL_F; +} +SCM l_dyn_call(symb, shl) + SCM symb, shl; +{ + int i; + void (*func)() = 0; +/* SCM oloadpath = *loc_loadpath; */ + ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call); + DEFER_INTS; + if ((i = dld_function_executable_p(CHARS(symb)))) + func = (void (*) ()) dld_get_func(CHARS(symb)); + else dld_perror("DLDP"); + ALLOW_INTS; + if (!i) listundefs(); + if (!func) { + dld_perror("DLD"); + return BOOL_F; + } +/* *loc_loadpath = linkpath; */ + (*func) (); +/* *loc_loadpath = oloadpath; */ + return BOOL_T; +} +static char s_main_call[] = "dyn:main-call"; +SCM l_dyn_main_call(symb, shl, args) + SCM symb, shl, args; +{ + int i; + int (*func)(int argc, char **argv) = 0; + char **argv; +/* SCM oloadpath = *loc_loadpath; */ + ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); + DEFER_INTS; + argv = makargvfrmstrs(args, s_main_call); + if ((i = dld_function_executable_p(CHARS(symb)))) + func = (int (*) (int argc, char **argv)) dld_get_func(CHARS(symb)); + else dld_perror("DLDP"); + if (!i) listundefs(); + if (!func) { + must_free_argv(argv); + ALLOW_INTS; + dld_perror("DLD"); + return BOOL_F; + } + ALLOW_INTS; +/* *loc_loadpath = linkpath; */ + i = (*func) ((int)ilength(args), argv); +/* *loc_loadpath = oloadpath; */ + DEFER_INTS; + must_free_argv(argv); + ALLOW_INTS; + return MAKINUM(0L+i); +} + +static char s_unlink[] = "dyn:unlink"; +SCM l_dyn_unlink(fname) + SCM fname; +{ + int status; + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink); + DEFER_INTS; + status = dld_unlink_by_file(CHARS(fname), 1); + ALLOW_INTS; + if (!status) return BOOL_T; + dld_perror("DLD"); + return BOOL_F; +} +static iproc subr1s[] = { + {s_link, l_dyn_link}, + {s_unlink, l_dyn_unlink}, + {0, 0}}; +void init_dynl() +{ +# ifndef RTL + if (!execpath) execpath = dld_find_executable(CHARS(CAR(progargs))); + if (dld_init(execpath)) { + dld_perror("DLD:"); +/* wta(CAR(progargs), "couldn't init", "dld"); */ + return; + } +# endif + init_iprocs(subr1s, tc7_subr_1); + make_subr(s_call, tc7_subr_2, l_dyn_call); + make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call); + add_feature("dld"); +# ifdef DLD_DYNCM + add_feature("dld:dyncm"); +# endif +} +#else + +# ifdef hpux +# include "dl.h" + +# define SHL(obj) ((shl_t*)CDR(obj)) +int prinshl(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#<shl ", port); + intprint(CDR(exp), 16, port); + lputc('>', port); + return 1; +} +int tc16_shl; +static smobfuns shlsmob = {mark0, free0, prinshl}; + +static char s_link[] = "dyn:link", s_call[] = "dyn:call"; +SCM l_dyn_link(fname) + SCM fname; +{ + SCM z; + shl_t shl; + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link); + DEFER_INTS; + shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L); + if (NULL==shl) { + ALLOW_INTS; + return BOOL_F; + } + NEWCELL(z); + SETCHARS(z, shl); + CAR(z) = tc16_shl; + ALLOW_INTS; +/* linkpath = fname; */ + return z; +} +SCM l_dyn_call(symb, shl) + SCM symb, shl; +{ + void (*func)() = 0; + int i; +/* SCM oloadpath = *loc_loadpath; */ + ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call); + ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call); + DEFER_INTS; + if ((i = shl_findsym(&SHL(shl), + CHARS(symb), + TYPE_PROCEDURE, &func)) != 0) { + puts(" undef:"); puts(CHARS(symb)); + } + ALLOW_INTS; + if (i != 0) return BOOL_F; +/* *loc_loadpath = linkpath; */ + (*func) (); +/* *loc_loadpath = oloadpath; */ + return BOOL_T; +} + +static char s_main_call[] = "dyn:main-call"; +SCM l_dyn_main_call(symb, shl, args) + SCM symb, shl, args; +{ + int i; + int (*func)P((int argc, char **argv)) = 0; + char **argv; +/* SCM oloadpath = *loc_loadpath; */ + ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call); + ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call); + DEFER_INTS; + if ((i = shl_findsym(&SHL(shl), + CHARS(symb), + TYPE_PROCEDURE, &func)) != 0) { + puts(" undef:"); puts(CHARS(symb)); + } + argv = makargvfrmstrs(args, s_main_call); + ALLOW_INTS; + if (i != 0) return BOOL_F; +/* *loc_loadpath = linkpath; */ + i = (*func) ((int)ilength(args), argv); +/* *loc_loadpath = oloadpath; */ + DEFER_INTS; + must_free_argv(argv); + ALLOW_INTS; + return MAKINUM(0L+i); +} + +static char s_unlink[] = "dyn:unlink"; +SCM l_dyn_unlink(shl) + SCM shl; +{ + int status; + ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink); + DEFER_INTS; + status = shl_unload(SHL(shl)); + ALLOW_INTS; + if (!status) return BOOL_T; + return BOOL_F; +} +static iproc subr1s[] = { + {s_link, l_dyn_link}, + {s_unlink, l_dyn_unlink}, + {0, 0}}; +void init_dynl() +{ + tc16_shl = newsmob(&shlsmob); + init_iprocs(subr1s, tc7_subr_1); + make_subr(s_call, tc7_subr_2, l_dyn_call); + make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call); + add_feature("shl"); +} +# endif +#endif + +#ifdef vms +/* 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); +} +#endif + + +#ifdef SUN_DL +# include <dlfcn.h> + +# define SHL(obj) ((void*)CDR(obj)) + +# ifdef SVR4 /* Solaris 2. */ +# define DLOPEN_MODE RTLD_LAZY +# else +# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ +# endif + +sizet frshl(ptr) + CELLPTR 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; +} + +int prinshl(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#<shl ", port); + intprint(CDR(exp), 16, port); + lputc('>', port); + return 1; +} +int tc16_shl; +static smobfuns shlsmob = {mark0, frshl, prinshl}; + +static char s_link[] = "dyn:link", s_call[] = "dyn:call"; +SCM l_dyn_link(fname) + SCM fname; +{ + SCM z; + void *handle; + if FALSEP(fname) return fname; + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link); + DEFER_INTS; + handle = dlopen(CHARS(fname), DLOPEN_MODE); + if (NULL==handle) { + ALLOW_INTS; + return BOOL_F; + } + NEWCELL(z); + SETCHARS(z, handle); + CAR(z) = tc16_shl; + ALLOW_INTS; +/* linkpath = fname; */ + return z; +} + +SCM l_dyn_call(symb, shl) + SCM symb, shl; +{ + void (*func)() = 0; +/* SCM oloadpath = *loc_loadpath; */ + ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call); + ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call); + DEFER_INTS; + func = dlsym(SHL(shl), CHARS(symb)); + if (!func) { + const char *dlr = dlerror(); + ALLOW_INTS; + if (dlr) puts(dlr); + return BOOL_F; + } + ALLOW_INTS; +/* *loc_loadpath = linkpath; */ + (*func) (); +/* *loc_loadpath = oloadpath; */ + return BOOL_T; +} +static char s_unlink[] = "dyn:unlink"; +SCM l_dyn_unlink(shl) + SCM shl; +{ + int status; + ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink); + DEFER_INTS; + status = dlclose(SHL(shl)); + SETCHARS(shl, NULL); + ALLOW_INTS; + if (!status) return BOOL_T; + return BOOL_F; +} +static iproc subr1s[] = { +{s_link, l_dyn_link}, +{s_unlink, l_dyn_unlink}, +{0, 0}}; + +void init_dynl() +{ + tc16_shl = newsmob(&shlsmob); + init_iprocs(subr1s, tc7_subr_1); + make_subr(s_call, tc7_subr_2, l_dyn_call); + add_feature("sun-dl"); +} +#endif /* SUN_DL */ @@ -0,0 +1,614 @@ +/* C code startup routine. + Copyright (C) 1985, 1986, 1992 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. */ + + +/* The standard Vax 4.2 Unix crt0.c cannot be used for Emacs + because it makes `environ' an initialized variable. + It is easiest to have a special crt0.c on all machines + though I don't know whether other machines actually need it. */ + +/* On the vax and 68000, in BSD4.2 and USG5.2, + this is the data format on startup: + (vax) ap and fp are unpredictable as far as I know; don't use them. + sp -> word containing argc + word pointing to first arg string + [word pointing to next arg string]... 0 or more times + 0 +Optionally: + [word pointing to environment variable]... 1 or more times + ... + 0 +And always: + first arg string + [next arg string]... 0 or more times +*/ + +/* On the 16000, at least in the one 4.2 system I know about, + the initial data format is + sp -> word containing argc + word containing argp + word pointing to first arg string, and so on as above +*/ + +#ifdef emacs +#include <config.h> +#endif + +/* ******** WARNING ******** + Do not insert any data definitions before data_start! + Since this is the first file linked, the address of the following + variable should correspond to the start of initialized data space. + On some systems this is a constant that is independent of the text + size for shared executables. On others, it is a function of the + text size. In short, this seems to be the most portable way to + discover the start of initialized data space dynamically at runtime, + for either shared or unshared executables, on either swapping or + virtual systems. It only requires that the linker allocate objects + in the order encountered, a reasonable model for most Unix systems. + Similarly, note that the address of _start() should be the start + of text space. Fred Fish, UniSoft Systems Inc. */ + +int data_start = 0; + +#ifdef NEED_ERRNO +int errno; +#endif + +#ifndef DONT_NEED_ENVIRON +char **environ; +#endif + +#ifndef static +/* On systems where the static storage class is usable, this function + should be declared as static. Otherwise, the static keyword has + been defined to be something else, and code for those systems must + take care of this declaration appropriately. */ +static start1 (); +#endif + +#ifdef APOLLO +extern char *malloc(), *realloc(), *(*_libc_malloc) (), *(*_libc_realloc)(); +extern void free(), (*_libc_free) (); extern int main(); +std_$call void unix_$main(); + +_start() +{ + _libc_malloc = malloc; + _libc_realloc = realloc; + _libc_free = free; + unix_$main(main); /* no return */ +} +#endif /* APOLLO */ + +#if defined(orion) || defined(pyramid) || defined(celerity) || defined(ALLIANT) || defined(clipper) || defined(sps7) + +#if defined(sps7) && defined(V3x) + asm(" section 10"); + asm(" ds.b 0xb0"); +#endif + +#ifdef ALLIANT +/* _start must initialize _curbrk and _minbrk on the first startup; + when starting up after dumping, it must initialize them to what they were + before the dumping, since they are in the shared library and + are not dumped. See ADJUST_EXEC_HEADER in m-alliant.h. */ +extern unsigned char *_curbrk, *_minbrk; +extern unsigned char end; +unsigned char *_setbrk = &end; +#ifdef ALLIANT_2800 +unsigned char *_end = &end; +#endif +#endif + +#ifndef DUMMIES +#define DUMMIES +#endif + +_start (DUMMIES argc, argv, envp) + int argc; + char **argv, **envp; +{ +#ifdef ALLIANT +#ifdef ALLIANT_2800 + _curbrk = _end; + _minbrk = _end; +#else + _curbrk = _setbrk; + _minbrk = _setbrk; +#endif +#endif + + environ = envp; + + exit (main (argc, argv, envp)); +} + +#endif /* orion or pyramid or celerity or alliant or clipper */ + +#if defined (ns16000) && !defined (sequent) && !defined (UMAX) && !defined (CRT0_DUMMIES) + +_start () +{ +/* On 16000, _start pushes fp onto stack */ + start1 (); +} + +/* ignore takes care of skipping the fp value pushed in start. */ +static +start1 (ignore, argc, argv) + int ignore; + int argc; + register char **argv; +{ + environ = argv + argc + 1; + + if (environ == *argv) + environ--; + exit (main (argc, argv, environ)); +} +#endif /* ns16000, not sequent and not UMAX, and not the CRT0_DUMMIES method */ + +#ifdef UMAX +_start() +{ + asm(" exit [] # undo enter"); + asm(" .set exitsc,1"); + asm(" .set sigcatchall,0x400"); + + asm(" .globl _exit"); + asm(" .globl start"); + asm(" .globl __start"); + asm(" .globl _main"); + asm(" .globl _environ"); + asm(" .globl _sigvec"); + asm(" .globl sigentry"); + + asm("start:"); + asm(" br .xstart"); + asm(" .org 0x20"); + asm(" .double p_glbl,0,0xf00000,0"); + asm(" .org 0x30"); + asm(".xstart:"); + asm(" adjspb $8"); + asm(" movd 8(sp),0(sp) # argc"); + asm(" addr 12(sp),r0"); + asm(" movd r0,4(sp) # argv"); + asm("L1:"); + asm(" movd r0,r1"); + asm(" addqd $4,r0"); + asm(" cmpqd $0,0(r1) # null args term ?"); + asm(" bne L1"); + asm(" cmpd r0,0(4(sp)) # end of 'env' or 'argv' ?"); + asm(" blt L2"); + asm(" addqd $-4,r0 # envp's are in list"); + asm("L2:"); + asm(" movd r0,8(sp) # env"); + asm(" movd r0,@_environ # indir is 0 if no env ; not 0 if env"); + asm(" movqd $0,tos # setup intermediate signal handler"); + asm(" addr @sv,tos"); + asm(" movzwd $sigcatchall,tos"); + asm(" jsr @_sigvec"); + asm(" adjspb $-12"); + asm(" jsr @_main"); + asm(" adjspb $-12"); + asm(" movd r0,tos"); + asm(" jsr @_exit"); + asm(" adjspb $-4"); + asm(" addr @exitsc,r0"); + asm(" svc"); + asm(" .align 4 # sigvec arg"); + asm("sv:"); + asm(" .double sigentry"); + asm(" .double 0"); + asm(" .double 0"); + + asm(" .comm p_glbl,1"); +} +#endif /* UMAX */ + +#ifdef CRT0_DUMMIES + +/* Define symbol "start": here; some systems want that symbol. */ +#ifdef DOT_GLOBAL_START +asm(" .text "); +asm(" .globl start "); +asm(" start: "); +#endif /* DOT_GLOBAL_START */ + +#ifdef NODOT_GLOBAL_START +asm(" text "); +asm(" global start "); +asm(" start: "); +#endif /* NODOT_GLOBAL_START */ + +#ifdef m68000 + +/* GCC 2.1, when optimization is turned off, seems to want to push a + word of garbage on the stack, which screws up the CRT0_DUMMIES + hack. So we hand-code _start in assembly language. */ +asm(".text "); +asm(" .even "); +asm(".globl __start "); +asm("__start: "); +asm(" link a6,#0 "); +asm(" jbsr _start1 "); +asm(" unlk a6 "); +asm(" rts "); + +#else /* not m68000 */ + +_start () +{ +/* On vax, nothing is pushed here */ +/* On sequent, bogus fp is pushed here */ + start1 (); +} + +#endif /* possibly m68000 */ + +static +start1 (CRT0_DUMMIES argc, xargv) + int argc; + char *xargv; +{ + register char **argv = &xargv; + environ = argv + argc + 1; + + if ((char *)environ == xargv) + environ--; + exit (main (argc, argv, environ)); + + /* Refer to `start1' so GCC will not think it is never called + and optimize it out. */ + (void) &start1; +} +#else /* not CRT0_DUMMIES */ + +/* "m68k" and "m68000" both stand for m68000 processors, + but with different program-entry conventions. + This is a kludge. Now that the CRT0_DUMMIES mechanism above exists, + most of these machines could use the vax code above + with some suitable definition of CRT0_DUMMIES. + Then the symbol m68k could be flushed. + But I don't want to risk breaking these machines + in a version 17 patch release, so that change is being put off. */ + +#ifdef m68k /* Can't do it all from C */ + asm (" global _start"); + asm (" text"); + asm ("_start:"); +#ifndef NU +#ifdef STRIDE + asm (" comm havefpu%,2"); +#else /* m68k, not STRIDE */ + asm (" comm splimit%,4"); +#endif /* STRIDE */ + asm (" global exit"); + asm (" text"); +#ifdef STRIDE + asm (" trap &3"); + asm (" mov.w %d0,havefpu%"); +#else /* m68k, not STRIDE */ + asm (" mov.l %d0,splimit%"); +#endif /* STRIDE */ +#endif /* not NU */ + asm (" jsr start1"); + asm (" mov.l %d0,(%sp)"); + asm (" jsr exit"); + asm (" mov.l &1,%d0"); /* d0 = 1 => exit */ + asm (" trap &0"); +#else /* m68000, not m68k */ + +#ifdef m68000 + +#ifdef ISI68K +/* Added by ESM Sun May 24 12:44:02 1987 to get new ISI library to work */ +/* Edited by Ray Mon May 15 15:59:56 EST 1989 so we can compile with gcc */ +#if defined(BSD4_3) && !defined(__GNUC__) +static foo () { +#endif + asm (" .globl is68020"); + asm ("is68020:"); +#ifndef BSD4_3 + asm (" .long 0x00000000"); + asm (" .long 0xffffffff"); +/* End of stuff added by ESM */ +#endif + asm (" .text"); + asm (" .globl __start"); + asm ("__start:"); + asm (" .word 0"); + asm (" link a6,#0"); + asm (" jbsr _start1"); + asm (" unlk a6"); + asm (" rts"); +#if defined(BSD4_3) && !defined(__GNUC__) + } +#endif +#else /* not ISI68K */ + +_start () +{ +#ifdef sun +#ifdef LISP_FLOAT_TYPE + finitfp_(); +#endif +#endif +/* On 68000, _start pushes a6 onto stack */ + start1 (); +} +#endif /* not ISI68k */ +#endif /* m68000 */ +#endif /* m68k */ + +#if defined(m68k) || defined(m68000) +/* ignore takes care of skipping the a6 value pushed in start. */ +static +#if defined(m68k) +start1 (argc, xargv) +#else +start1 (ignore, argc, xargv) +#endif + int argc; + char *xargv; +{ + register char **argv = &xargv; + environ = argv + argc + 1; + + if ((char *)environ == xargv) + environ--; +#ifdef sun_68881 + asm(" jsr f68881_used"); +#endif +#ifdef sun_fpa + asm(" jsr ffpa_used"); +#endif +#ifdef sun_soft + asm(" jsr start_float"); +#endif + exit (main (argc, argv, environ)); +} + +#endif /* m68k or m68000 */ + +#endif /* not CRT0_DUMMIES */ + +#ifdef hp9000s300 +int argc_value; +char **argv_value; +#ifdef OLD_HP_ASSEMBLER + asm(" text"); + asm(" globl __start"); + asm(" globl _exit"); + asm(" globl _main"); + asm("__start"); + asm(" dc.l 0"); + asm(" subq.w #0x1,d0"); + asm(" move.w d0,float_soft"); + asm(" move.l 0x4(a7),d0"); + asm(" beq.s skip_1"); + asm(" move.l d0,a0"); + asm(" clr.l -0x4(a0)"); + asm("skip_1"); + asm(" move.l a7,a0"); + asm(" subq.l #0x8,a7"); + asm(" move.l (a0),(a7)"); + asm(" move.l (a0),_argc_value"); + asm(" addq.l #0x4,a0"); + asm(" move.l a0,0x4(a7)"); + asm(" move.l a0,_argv_value"); + asm("incr_loop"); + asm(" tst.l (a0)+"); + asm(" bne.s incr_loop"); + asm(" move.l 0x4(a7),a1"); + asm(" cmp.l (a1),a0"); + asm(" blt.s skip_2"); + asm(" subq.l #0x4,a0"); + asm("skip_2"); + asm(" move.l a0,0x8(a7)"); + asm(" move.l a0,_environ"); + asm(" jsr _main"); + asm(" addq.l #0x8,a7"); + asm(" move.l d0,-(a7)"); + asm(" jsr _exit"); + asm(" move.w #0x1,d0"); + asm(" trap #0x0"); + asm(" comm float_soft,4"); +/* float_soft is allocated in this way because C would + put an underscore character in its name otherwise. */ + +#else /* new hp assembler */ + + asm(" text"); + asm(" global float_loc"); + asm(" set float_loc,0xFFFFB000"); + asm(" global fpa_loc"); + asm(" set fpa_loc,0xfff08000"); + asm(" global __start"); + asm(" global _exit"); + asm(" global _main"); + asm("__start:"); + asm(" byte 0,0,0,0"); + asm(" subq.w &1,%d0"); + asm(" mov.w %d0,float_soft"); + asm(" mov.w %d1,flag_68881"); +#ifndef HPUX_68010 + asm(" beq.b skip_float"); + asm(" fmov.l &0x7400,%fpcr"); +/* asm(" fmov.l &0x7480,%fpcr"); */ +#endif /* HPUX_68010 */ + asm("skip_float:"); + asm(" mov.l %a0,%d0"); + asm(" add.l %d0,%d0"); + asm(" subx.w %d1,%d1"); + asm(" mov.w %d1,flag_68010"); + asm(" add.l %d0,%d0"); + asm(" subx.w %d1,%d1"); + asm(" mov.w %d1,flag_fpa"); + asm(" tst.l %d2"); + asm(" ble.b skip_3"); + asm(" lsl flag_68881"); + asm(" lsl flag_fpa"); + asm("skip_3:"); + asm(" mov.l 4(%a7),%d0"); + asm(" beq.b skip_1"); + asm(" mov.l %d0,%a0"); + asm(" clr.l -4(%a0)"); + asm("skip_1:"); + asm(" mov.l %a7,%a0"); + asm(" subq.l &8,%a7"); + asm(" mov.l (%a0),(%a7)"); + asm(" mov.l (%a0),_argc_value"); + asm(" addq.l &4,%a0"); + asm(" mov.l %a0,4(%a7)"); + asm(" mov.l %a0,_argv_value"); + asm("incr_loop:"); + asm(" tst.l (%a0)+"); + asm(" bne.b incr_loop"); + asm(" mov.l 4(%a7),%a1"); + asm(" cmp.l %a0,(%a1)"); + asm(" blt.b skip_2"); + asm(" subq.l &4,%a0"); + asm("skip_2:"); + asm(" mov.l %a0,8(%a7)"); + asm(" mov.l %a0,_environ"); + asm(" jsr _main"); + asm(" addq.l &8,%a7"); + asm(" mov.l %d0,-(%a7)"); + asm(" jsr _exit"); + asm(" mov.w &1,%d0"); + asm(" trap &0"); + asm(" comm float_soft, 4"); + asm(" comm flag_68881, 4"); + asm(" comm flag_68010, 4"); + asm(" comm flag_68040, 4"); + asm(" comm flag_fpa, 4"); + +#endif /* new hp assembler */ +#endif /* hp9000s300 */ + +#ifdef GOULD + +/* startup code has to be in near text rather + than fartext as allocated by the C compiler. */ + asm(" .text"); + asm(" .align 2"); + asm(" .globl __start"); + asm(" .text"); + asm("__start:"); +/* setup base register b1 (function base). */ + asm(" .using b1,."); + asm(" tpcbr b1"); +/* setup base registers b3 through b7 (data references). */ + asm(" file basevals,b3"); +/* setup base register b2 (stack pointer); it should be + aligned on a 8-word boundary; but because it is pointing + to argc, its value should be remembered (in r5). */ + asm(" movw b2,r4"); + asm(" movw b2,r5"); + asm(" andw #~0x1f,r4"); + asm(" movw r4,b2"); +/* allocate stack frame to do some work. */ + asm(" subea 16w,b2"); +/* initialize signal catching for UTX/32 1.2; this is + necessary to make restart from saved image work. */ + asm(" movea sigcatch,r1"); + asm(" movw r1,8w[b2]"); + asm(" svc #1,#150"); +/* setup address of argc for start1. */ + asm(" movw r5,8w[b2]"); + asm(" func #1,_start1"); + asm(" halt"); +/* space for ld to store base register initial values. */ + asm(" .align 5"); + asm("basevals:"); + asm(" .word __base3,__base4,__base5,__base6,__base7"); + +static +start1 (xargc) + int *xargc; +{ + register int argc; + register char **argv; + + argc = *xargc; + argv = (char **)(xargc) + 1; + environ = argv + argc + 1; + + if (environ == argv) + environ--; + exit (main (argc, argv, environ)); + +} + +#endif /* GOULD */ + +#ifdef elxsi +#include <elxsi/argvcache.h> + +extern char **environ; +extern int errno; +extern void _init_doscan(), _init_iob(); +extern char end[]; +char *_init_brk = end; + +_start() +{ + environ = exec_cache.ac_envp; + brk (_init_brk); + errno = 0; + _init_doscan (); + _init_iob (); + _exit (exit (main (exec_cache.ac_argc, + exec_cache.ac_argv, + exec_cache.ac_envp))); +} +#endif /* elxsi */ + + +#ifdef sparc +asm (".global __start"); +asm (".text"); +asm ("__start:"); +asm (" mov 0, %fp"); +asm (" ld [%sp + 64], %o0"); +asm (" add %sp, 68, %o1"); +asm (" sll %o0, 2, %o2"); +asm (" add %o2, 4, %o2"); +asm (" add %o1, %o2, %o2"); +asm (" sethi %hi(_environ), %o3"); +asm (" st %o2, [%o3+%lo(_environ)]"); +asm (" andn %sp, 7, %sp"); +asm (" call _main"); +asm (" sub %sp, 24, %sp"); +asm (" call __exit"); +asm (" nop"); + +#endif /* sparc */ + +#if __FreeBSD__ == 2 +char *__progname; +#endif +#ifdef __bsdi__ +#include <sys/param.h> /* for version number */ +#if defined(_BSDI_VERSION) && (_BSDI_VERSION >= 199501) +char *__progname; +#endif +#endif /* __bsdi__ */ diff --git a/edline.c b/edline.c new file mode 100644 index 0000000..ab15578 --- /dev/null +++ b/edline.c @@ -0,0 +1,94 @@ +/* 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. + */ + +/* "readline.c" Scheme interface to readline library + Author: Radey Shouman */ + +#include "scm.h" + +char *readline P((const char *prompt)); +void add_history P((char *p)); + + /* Reads on stdin/stdout only */ +static char s_readline[] = "read-edited-line"; +SCM lreadline(prompt) + SCM prompt; +{ + SCM res; + char *s; + ASSERT(NIMP(prompt) && STRINGP(prompt), prompt, ARG1, s_readline); + s = readline(CHARS(prompt)); + if (NULL == s) return EOF_VAL; + NEWCELL(res); + DEFER_INTS; + SETCHARS(res,s); + SETLENGTH(res,(sizet)strlen(s),tc7_string); + ALLOW_INTS; + return res; +} +static char s_add_history[] = "add-history"; +SCM ladd_history(line) + SCM line; +{ + ASSERT(NIMP(line) && STRINGP(line), line, ARG1, s_add_history); + add_history(CHARS(line)); + return UNSPECIFIED; +} +static char s_def_inport[] = "default-input-port"; +SCM def_inport() +{ + return def_inp; +} +static char s_def_outport[] = "default-output-port"; +SCM def_outport() +{ + return def_outp; +} +static char s_Iedline[] = "Iedline.scm"; +void init_edline() +{ + make_subr(s_def_inport, tc7_subr_0, def_inport); + make_subr(s_def_outport, tc7_subr_0, def_outport); + make_subr(s_readline, tc7_subr_1, lreadline); + make_subr(s_add_history, tc7_subr_1, ladd_history); + if (scm_ldprog(s_Iedline)) + wta(*loc_errobj, "couldn't init", s_Iedline); +} @@ -0,0 +1,1494 @@ +/* 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. + */ + +/* "eval.c" eval and apply. + Authors: Aubrey Jaffer & Hugh E. Secker-Walker. */ + +#include "scm.h" +#include "setjump.h" + +#define I_SYM(x) (CAR((x)-1L)) +#define I_VAL(x) (CDR((x)-1L)) +#define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env) +#ifdef MEMOIZE_LOCALS +# define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x) +#else +# define EVALIMP(x, env) x +#endif +#define EVALCAR(x, env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x), env):\ + I_VAL(CAR(x))):EVALCELLCAR(x, env)) +#define EXTEND_ENV acons + +#ifdef MEMOIZE_LOCALS +SCM *ilookup(iloc, env) + SCM iloc, env; +{ + register int ir = IFRAME(iloc); + register SCM er = env; + for(;0 != ir;--ir) er = CDR(er); + er = CAR(er); + for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er); + if ICDRP(iloc) return &CDR(er); + return &CAR(CDR(er)); +} +#endif +SCM *lookupcar(vloc, genv) + SCM vloc, genv; +{ + SCM env = genv; + register SCM *al, fl, var = CAR(vloc); +#ifdef MEMOIZE_LOCALS + register SCM iloc = ILOC00; +#endif + for(;NIMP(env);env = CDR(env)) { + al = &CAR(env); + for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) { + if NCONSP(fl) + if (fl==var) { +#ifdef MEMOIZE_LOCALS + CAR(vloc) = iloc + ICDR; +#endif + return &CDR(*al); + } + else break; + al = &CDR(*al); + if (CAR(fl)==var) { +#ifdef MEMOIZE_LOCALS +# ifndef RECKLESS /* letrec inits to UNDEFINED */ + if UNBNDP(CAR(*al)) {env = EOL; goto errout;} +# endif + CAR(vloc) = iloc; +#endif + return &CAR(*al); + } +#ifdef MEMOIZE_LOCALS + iloc += IDINC; +#endif + } +#ifdef MEMOIZE_LOCALS + iloc = (~IDSTMSK) & (iloc + IFRINC); +#endif + } + var = sym2vcell(var); +#ifndef RECKLESS + if (NNULLP(env) || UNBNDP(CDR(var))) { + var = CAR(var); + errout: + everr(vloc, genv, var, + NULLP(env)?"unbound variable: ":"damaged environment", ""); + } +#endif + CAR(vloc) = var + 1; + return &CDR(var); +} +static SCM unmemocar(form, env) + SCM form, env; +{ + register int ir; + if IMP(form) return form; + if (1==TYP3(form)) + CAR(form) = I_SYM(CAR(form)); +#ifdef MEMOIZE_LOCALS + else if ILOCP(CAR(form)) { + for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env); + env = CAR(CAR(env)); + for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env); + CAR(form) = ICDRP(CAR(form)) ? env : CAR(env); + } +#endif + return form; +} + +SCM eval_args(l, env) + SCM l, env; +{ + SCM res = EOL, *lloc = &res; + while NIMP(l) { + *lloc = cons(EVALCAR(l, env), EOL); + lloc = &CDR(*lloc); + l = CDR(l); + } + return res; +} + + /* the following rewrite expressions and + * some memoized forms have different syntax */ + +static char s_expression[] = "missing or extra expression"; +static char s_test[] = "bad test"; +static char s_body[] = "bad body"; +static char s_bindings[] = "bad bindings"; +static char s_variable[] = "bad variable"; +static char s_clauses[] = "bad or missing clauses"; +static char s_formals[] = "bad formals"; +#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr); + +SCM i_dot, i_quote, i_quasiquote, i_lambda, + i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply; +static char s_quasiquote[] = "quasiquote"; +static char s_delay[] = "delay"; + +#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what); + +static void bodycheck(xorig, bodyloc, what) + SCM xorig, *bodyloc; + char *what; +{ + ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression); +} + +SCM m_quote(xorig, env) + SCM xorig, env; +{ + ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote); + return cons(IM_QUOTE, CDR(xorig)); +} + +SCM m_begin(xorig, env) + SCM xorig, env; +{ + ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin); + return cons(IM_BEGIN, CDR(xorig)); +} + +SCM m_if(xorig, env) + SCM xorig, env; +{ + int len = ilength(CDR(xorig)); + ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if); + return cons(IM_IF, CDR(xorig)); +} + +SCM m_set(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + ASSYNT(2==ilength(x), xorig, s_expression, s_set); + ASSYNT(NIMP(CAR(x)) && SYMBOLP(CAR(x)), + xorig, s_variable, s_set); + return cons(IM_SET, x); +} + +SCM m_and(xorig, env) + SCM xorig, env; +{ + int len = ilength(CDR(xorig)); + ASSYNT(len >= 0, xorig, s_test, s_and); + if (len >= 1) return cons(IM_AND, CDR(xorig)); + else return BOOL_T; +} + +SCM m_or(xorig, env) + SCM xorig, env; +{ + int len = ilength(CDR(xorig)); + ASSYNT(len >= 0, xorig, s_test, s_or); + if (len >= 1) return cons(IM_OR, CDR(xorig)); + else return BOOL_F; +} + +SCM m_case(xorig, env) + SCM xorig, env; +{ + SCM proc, x = CDR(xorig); + ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case); + while(NIMP(x = CDR(x))) { + proc = CAR(x); + ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case); + ASSYNT(ilength(CAR(proc)) >= 0 || i_else==CAR(proc), + xorig, s_clauses, s_case); + } + return cons(IM_CASE, CDR(xorig)); +} + +SCM m_cond(xorig, env) + SCM xorig, env; +{ + SCM arg1, x = CDR(xorig); + int len = ilength(x); + ASSYNT(len >= 1, xorig, s_clauses, s_cond); + while(NIMP(x)) { + arg1 = CAR(x); + len = ilength(arg1); + ASSYNT(len >= 1, xorig, s_clauses, s_cond); + if (i_else==CAR(arg1)) { + ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond); + CAR(arg1) = BOOL_T; + } + if (len >= 2 && i_arrow==CAR(CDR(arg1))) + ASSYNT(3==len && NIMP(CAR(CDR(CDR(arg1)))), + xorig, "bad recipient", s_cond); + x = CDR(x); + } + return cons(IM_COND, CDR(xorig)); +} + +SCM m_lambda(xorig, env) + SCM xorig, env; +{ + SCM proc, x = CDR(xorig); + if (ilength(x) < 2) goto badforms; + proc = CAR(x); + if NULLP(proc) goto memlambda; + if IMP(proc) goto badforms; + if SYMBOLP(proc) goto memlambda; + if NCONSP(proc) goto badforms; + while NIMP(proc) { + if NCONSP(proc) + if (!SYMBOLP(proc)) goto badforms; + else goto memlambda; + if (!(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)))) goto badforms; + proc = CDR(proc); + } + if NNULLP(proc) + badforms: wta(xorig, s_formals, s_lambda); + memlambda: + bodycheck(xorig, &CDR(x), s_lambda); + return cons(IM_LAMBDA, CDR(xorig)); +} +SCM m_letstar(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig), arg1, proc, vars = EOL, *varloc = &vars; + int len = ilength(x); + ASSYNT(len >= 2, xorig, s_body, s_letstar); + proc = CAR(x); + ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_letstar); + while NIMP(proc) { + arg1 = CAR(proc); + ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar); + ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_letstar); + *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL); + varloc = &CDR(CDR(*varloc)); + proc = CDR(proc); + } + x = cons(vars, CDR(x)); + bodycheck(xorig, &CDR(x), s_letstar); + return cons(IM_LETSTAR, x); +} + +/* DO gets the most radically altered syntax + (do ((<var1> <init1> <step1>) + (<var2> <init2>) + ... ) + (<test> <return>) + <body>) + ;; becomes + (do_mem (varn ... var2 var1) + (<init1> <init2> ... <initn>) + (<test> <return>) + (<body>) + <step1> <step2> ... <stepn>) ;; missing steps replaced by var + */ +SCM m_do(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig), arg1, proc; + SCM vars = EOL, inits = EOL, steps = EOL; + SCM *initloc = &inits, *steploc = &steps; + int len = ilength(x); + ASSYNT(len >= 2, xorig, s_test, s_do); + proc = CAR(x); + ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do); + while NIMP(proc) { + arg1 = CAR(proc); + len = ilength(arg1); + ASSYNT(2==len || 3==len, xorig, s_bindings, s_do); + ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_do); + /* vars reversed here, inits and steps reversed at evaluation */ + vars = cons(CAR(arg1), vars); /* variable */ + arg1 = CDR(arg1); + *initloc = cons(CAR(arg1), EOL); /* init */ + initloc = &CDR(*initloc); + arg1 = CDR(arg1); + *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */ + steploc = &CDR(*steploc); + proc = CDR(proc); + } + x = CDR(x); + ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do); + x = cons2(CAR(x), CDR(x), steps); + x = cons2(vars, inits, x); + bodycheck(xorig, &CAR(CDR(CDR(x))), s_do); + return cons(IM_DO, x); +} + +/* evalcar is small version of inline EVALCAR when we don't care about speed */ +static SCM evalcar(x, env) + SCM x, env; +{ + return EVALCAR(x, env); +} + +static SCM iqq(form, env, depth) + SCM form, env; + int depth; +{ + SCM tmp; + int edepth = depth; + if IMP(form) return form; + if VECTORP(form) { + long i = LENGTH(form); + SCM *data = VELTS(form); + tmp = EOL; + for(;--i >= 0;) tmp = cons(data[i], tmp); + return vector(iqq(tmp, env, depth)); + } + if NCONSP(form) return form; + tmp = CAR(form); + if (i_quasiquote==tmp) { + depth++; + goto label; + } + if (i_unquote==tmp) { + --depth; + label: + form = CDR(form); + ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)), + form, ARG1, s_quasiquote); + if (0==depth) return evalcar(form, env); + return cons2(tmp, iqq(CAR(form), env, depth), EOL); + } + if (NIMP(tmp) && (i_uq_splicing==CAR(tmp))) { + tmp = CDR(tmp); + if (0==--edepth) + return append(cons2(evalcar(tmp, env), iqq(CDR(form), env, depth), EOL)); + } + return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth)); +} + +/* Here are acros which return values rather than code. */ + +SCM m_quasiquote(xorig, env) + SCM xorig, env; +{ + SCM x = CDR(xorig); + ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote); + return iqq(CAR(x), env, 1); +} + +SCM m_delay(xorig, env) + SCM xorig, env; +{ + ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay); + xorig = CDR(xorig); + return makprom(closure(cons2(EOL, CAR(xorig), CDR(xorig)), env)); +} + +extern int verbose; +SCM m_define(x, env) + SCM x, env; +{ + SCM proc, arg1 = x; x = CDR(x); + /* ASSYNT(NULLP(env), x, "bad placement", s_define);*/ + ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define); + proc = CAR(x); x = CDR(x); + while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */ + x = cons(cons2(i_lambda, CDR(proc), x), EOL); + proc = CAR(proc); + } + ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define); + ASSYNT(1==ilength(x), arg1, s_expression, s_define); + if NULLP(env) { + x = evalcar(x, env); + arg1 = sym2vcell(proc); +#ifndef RECKLESS + if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc) + && (CDR(arg1) != x)) + warn("redefining built-in ", CHARS(proc)); + else +#endif + if (5 <= verbose && UNDEFINED != CDR(arg1)) + warn("redefining ", CHARS(proc)); + CDR(arg1) = x; +#ifdef SICP + return cons2(i_quote, CAR(arg1), EOL); +#else + return UNSPECIFIED; +#endif + } + return cons2(IM_DEFINE, proc, x); +} +/* end of acros */ + +SCM m_letrec(xorig, env) + SCM xorig, env; +{ + SCM cdrx = CDR(xorig); /* locally mutable version of form */ + char *what = CHARS(CAR(xorig)); + SCM x = cdrx, proc, arg1; /* structure traversers */ + SCM vars = EOL, inits = EOL, *initloc = &inits; + + ASRTSYNTAX(ilength(x) >= 2, s_body); + proc = CAR(x); + if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */ + ASRTSYNTAX(ilength(proc) >= 1, s_bindings); + do { + /* vars list reversed here, inits reversed at evaluation */ + arg1 = CAR(proc); + ASRTSYNTAX(2==ilength(arg1), s_bindings); + ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), s_variable); + vars = cons(CAR(arg1), vars); + *initloc = cons(CAR(CDR(arg1)), EOL); + initloc = &CDR(*initloc); + } while NIMP(proc = CDR(proc)); + cdrx = cons2(vars, inits, CDR(x)); + bodycheck(xorig, &CDR(CDR(cdrx)), what); + return cons(IM_LETREC, cdrx); +} + +SCM m_let(xorig, env) + SCM xorig, env; +{ + SCM cdrx = CDR(xorig); /* locally mutable version of form */ + SCM x = cdrx, proc, arg1, name; /* structure traversers */ + SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits; + + ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); + proc = CAR(x); + if (NULLP(proc) + || (NIMP(proc) && CONSP(proc) + && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc)))) + return m_letstar(xorig, env); /* null or single binding, let* is faster */ + ASSYNT(NIMP(proc), xorig, s_bindings, s_let); + if CONSP(proc) /* plain let, proc is <bindings> */ + return cons(IM_LET, CDR(m_letrec(xorig, env))); + if (!SYMBOLP(proc)) wta(xorig, s_bindings, s_let); /* bad let */ + name = proc; /* named let, build equiv letrec */ + x = CDR(x); + ASSYNT(ilength(x) >= 2, xorig, s_body, s_let); + proc = CAR(x); /* bindings list */ + ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let); + while NIMP(proc) { /* vars and inits both in order */ + arg1 = CAR(proc); + ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let); + ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let); + *varloc = cons(CAR(arg1), EOL); + varloc = &CDR(*varloc); + *initloc = cons(CAR(CDR(arg1)), EOL); + initloc = &CDR(*initloc); + proc = CDR(proc); + } + return + m_letrec(cons2(i_let, + cons(cons2(name, cons2(i_lambda, vars, CDR(x)), EOL), EOL), + acons(name, inits, EOL)), /* body */ + env); +} + +#define s_atapply (ISYMCHARS(IM_APPLY)+1) + +SCM m_apply(xorig, env) + SCM xorig, env; +{ + ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply); + return cons(IM_APPLY, CDR(xorig)); +} + +#define s_atcall_cc (ISYMCHARS(IM_CONT)+1) + +SCM m_cont(xorig, env) + SCM xorig, env; +{ + ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc); + return cons(IM_CONT, CDR(xorig)); +} + +#ifndef RECKLESS +int badargsp(formals, args) + SCM formals, args; +{ + while NIMP(formals) { + if NCONSP(formals) return 0; + if IMP(args) return 1; + formals = CDR(formals); + args = CDR(args); + } + return NNULLP(args) ? 1 : 0; +} +#endif + +char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval"; +SCM eqv P((SCM x, SCM y)); +long tc16_macro; /* Type code for macros */ +#ifdef CAUTIOUS +static char s_bottom[] = "stacktrace bottommed out"; +#endif + +SCM ceval(x, env) + SCM x, env; +{ + union {SCM *lloc; SCM arg1;} t; + SCM proc, arg2; + CHECK_STACK; + loop: POLL; + switch TYP7(x) { + case tcs_symbols: + /* only happens when called at top level */ + x = cons(x, UNDEFINED); + goto retval; + case (127 & IM_AND): + x = CDR(x); + t.arg1 = x; + while(NNULLP(t.arg1 = CDR(t.arg1))) + if FALSEP(EVALCAR(x, env)) return BOOL_F; + else x = t.arg1; + goto carloop; + cdrtcdrxbegin: +#ifdef CAUTIOUS + ASSERT(NIMP(stacktrace), EOL, s_bottom, s_eval); + stacktrace = CDR(stacktrace); +#endif + cdrxbegin: + case (127 & IM_BEGIN): + x = CDR(x); + begin: + t.arg1 = x; + while(NNULLP(t.arg1 = CDR(t.arg1))) { + SIDEVAL(CAR(x), env); + x = t.arg1; + } + carloop: /* eval car of last form in list */ + if NCELLP(CAR(x)) { + x = CAR(x); + return IMP(x)?EVALIMP(x, env):I_VAL(x); + } + if SYMBOLP(CAR(x)) { + retval: + return *lookupcar(x, env); + } + x = CAR(x); + goto loop; /* tail recurse */ + + case (127 & IM_CASE): + x = CDR(x); + t.arg1 = EVALCAR(x, env); + while(NIMP(x = CDR(x))) { + proc = CAR(x); + if (i_else==CAR(proc)) { + x = CDR(proc); + goto begin; + } + proc = CAR(proc); + while NIMP(proc) { + if (CAR(proc)==t.arg1 +#ifdef FLOATS + || NFALSEP(eqv(CAR(proc), t.arg1)) +#endif + ) { + x = CDR(CAR(x)); + goto begin; + } + proc = CDR(proc); + } + } + return UNSPECIFIED; + case (127 & IM_COND): + while(NIMP(x = CDR(x))) { + proc = CAR(x); + t.arg1 = EVALCAR(proc, env); + if NFALSEP(t.arg1) { + x = CDR(proc); + if NULLP(x) return t.arg1; + if (i_arrow != CAR(x)) goto begin; + proc = CDR(x); + proc = EVALCAR(proc, env); + ASRTGO(NIMP(proc), badfun); +#ifdef CAUTIOUS + if CLOSUREP(proc) goto checkargs1; +#endif + goto evap1; + } + } + return UNSPECIFIED; + case (127 & IM_DO): + x = CDR(x); + proc = CAR(CDR(x)); /* inits */ + t.arg1 = EOL; /* values */ + while NIMP(proc) { + t.arg1 = cons(EVALCAR(proc, env), t.arg1); + proc = CDR(proc); + } + env = EXTEND_ENV(CAR(x), t.arg1, env); + x = CDR(CDR(x)); + while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) { + for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) { + t.arg1 = CAR(proc); /* body */ + SIDEVAL(t.arg1, env); + } + for(t.arg1 = EOL, proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) + t.arg1 = cons(EVALCAR(proc, env), t.arg1); /* steps */ + env = EXTEND_ENV(CAR(CAR(env)), t.arg1, CDR(env)); + } + x = CDR(proc); + if NULLP(x) return UNSPECIFIED; + goto begin; + case (127 & IM_IF): + x = CDR(x); + if NFALSEP(EVALCAR(x, env)) x = CDR(x); + else if IMP(x = CDR(CDR(x))) return UNSPECIFIED; + goto carloop; + case (127 & IM_LET): + x = CDR(x); + proc = CAR(CDR(x)); + t.arg1 = EOL; + do { + t.arg1 = cons(EVALCAR(proc, env), t.arg1); + } while NIMP(proc = CDR(proc)); + env = EXTEND_ENV(CAR(x), t.arg1, env); + x = CDR(x); + goto cdrxbegin; + case (127 & IM_LETREC): + x = CDR(x); + env = EXTEND_ENV(CAR(x), undefineds, env); + x = CDR(x); + proc = CAR(x); + t.arg1 = EOL; + do { + t.arg1 = cons(EVALCAR(proc, env), t.arg1); + } while NIMP(proc = CDR(proc)); + CDR(CAR(env)) = t.arg1; + goto cdrxbegin; + case (127 & IM_LETSTAR): + x = CDR(x); + proc = CAR(x); + if IMP(proc) { + env = EXTEND_ENV(EOL, EOL, env); + goto cdrxbegin; + } + do { + t.arg1 = CAR(proc); + proc = CDR(proc); + env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env); + } while NIMP(proc = CDR(proc)); + goto cdrxbegin; + case (127 & IM_OR): + x = CDR(x); + t.arg1 = x; + while(NNULLP(t.arg1 = CDR(t.arg1))) { + x = EVALCAR(x, env); + if NFALSEP(x) return x; + x = t.arg1; + } + goto carloop; + case (127 & IM_LAMBDA): + return closure(CDR(x), env); + case (127 & IM_QUOTE): + return CAR(CDR(x)); + case (127 & IM_SET): + x = CDR(x); + proc = CAR(x); + switch (7 & (int)proc) { + case 0: + t.lloc = lookupcar(x, env); + break; + case 1: + t.lloc = &I_VAL(proc); + break; +#ifdef MEMOIZE_LOCALS + case 4: + t.lloc = ilookup(proc, env); + break; +#endif + } + x = CDR(x); + *t.lloc = EVALCAR(x, env); +#ifdef SICP + return *t.lloc; +#else + return UNSPECIFIED; +#endif + case (127 & IM_DEFINE): /* only for internal defines */ + x = CDR(x); + proc = CAR(x); + x = CDR(x); + x = evalcar(x, env); + env = CAR(env); + DEFER_INTS; + CAR(env) = cons(proc, CAR(env)); + CDR(env) = cons(x, CDR(env)); + ALLOW_INTS; + return UNSPECIFIED; + /* new syntactic forms go here. */ + case (127 & MAKISYM(0)): + proc = CAR(x); + ASRTGO(ISYMP(proc), badfun); + switch ISYMNUM(proc) { + case (ISYMNUM(IM_APPLY)): + proc = CDR(x); + proc = EVALCAR(proc, env); + ASRTGO(NIMP(proc), badfun); + if (CLOSUREP(proc)) { + t.arg1 = CDR(CDR(x)); + t.arg1 = EVALCAR(t.arg1, env); +#ifndef RECKLESS + if (badargsp(CAR(CODE(proc)), t.arg1)) goto wrongnumargs; +#endif + env = EXTEND_ENV(CAR(CODE(proc)), t.arg1, ENV(proc)); + x = CODE(proc); + goto cdrxbegin; + } + proc = i_apply; + goto evapply; + case (ISYMNUM(IM_CONT)): + t.arg1 = scm_make_cont(); + if (proc = setjmp(CONT(t.arg1)->jmpbuf)) +#ifdef SHORT_INT + return (SCM)thrown_value; +#else + return (SCM)proc; +#endif + proc = CDR(x); + proc = evalcar(proc, env); + ASRTGO(NIMP(proc), badfun); +#ifdef CAUTIOUS + if CLOSUREP(proc) { + checkargs1: + stacktrace = cons(x, stacktrace); + /* Check that argument list of proc can match 1 arg. */ + arg2 = CAR(CODE(proc)); + ASRTGO(NIMP(arg2), wrongnumargs); + if NCONSP(arg2) goto evap1; + arg2 = CDR(arg2); + ASRTGO(NULLP(arg2) || NCONSP(arg2), wrongnumargs); + } +#endif + goto evap1; + default: + goto badfun; + } + default: + proc = x; + badfun: + everr(x, env, proc, "Wrong type to apply: ", ""); + case tc7_vector: + case tc7_bvect: case tc7_ivect: case tc7_uvect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: + case tc7_string: + case tc7_smob: + return x; +#ifdef MEMOIZE_LOCALS + case (127 & ILOC00): + proc = *ilookup(CAR(x), env); + ASRTGO(NIMP(proc), badfun); +# ifndef RECKLESS +# ifdef CAUTIOUS + goto checkargs; +# endif +# endif + break; +#endif /* ifdef MEMOIZE_LOCALS */ + case tcs_cons_gloc: + proc = I_VAL(CAR(x)); + ASRTGO(NIMP(proc), badfun); +#ifndef RECKLESS +# ifdef CAUTIOUS + goto checkargs; +# endif +#endif + break; + case tcs_cons_nimcar: + if SYMBOLP(CAR(x)) { + proc = *lookupcar(x, env); + if IMP(proc) {unmemocar(x, env); goto badfun;} + if (tc16_macro==TYP16(proc)) { + unmemocar(x, env); + t.arg1 = apply(CDR(proc), x, cons(env, listofnull)); + switch ((int)(CAR(proc)>>16)) { + case 2: + if (ilength(t.arg1) <= 0) + t.arg1 = cons2(IM_BEGIN, t.arg1, EOL); + DEFER_INTS; + CAR(x) = CAR(t.arg1); + CDR(x) = CDR(t.arg1); + ALLOW_INTS; + goto loop; + case 1: + if NIMP(x = t.arg1) goto loop; + case 0: + return t.arg1; + } + } + } + else proc = ceval(CAR(x), env); + ASRTGO(NIMP(proc), badfun); +#ifndef RECKLESS +# ifdef CAUTIOUS + checkargs: +# endif + /* At this point proc is the evaluated procedure from the function + position and x has the form which is being evaluated. */ + if CLOSUREP(proc) { +# ifdef CAUTIOUS + stacktrace = cons(x, stacktrace); +# endif + arg2 = CAR(CODE(proc)); + t.arg1 = CDR(x); + while NIMP(arg2) { + if NCONSP(arg2) { + goto evapply; + } + if IMP(t.arg1) goto umwrongnumargs; + arg2 = CDR(arg2); + t.arg1 = CDR(t.arg1); + } + if NNULLP(t.arg1) goto umwrongnumargs; + } +#endif + } + evapply: + if NULLP(CDR(x)) switch TYP7(proc) { /* no arguments given */ + case tc7_subr_0: + return SUBRF(proc)(); + case tc7_subr_1o: + return SUBRF(proc) (UNDEFINED); + case tc7_lsubr: + return SUBRF(proc)(EOL); + case tc7_rpsubr: + return BOOL_T; + case tc7_asubr: + return SUBRF(proc)(UNDEFINED, UNDEFINED); +#ifdef CCLO + case tc7_cclo: + t.arg1 = proc; + proc = CCLO_SUBR(proc); + goto evap1; +#endif + case tcs_closures: + x = CODE(proc); + env = EXTEND_ENV(CAR(x), EOL, ENV(proc)); + goto cdrtcdrxbegin; + case tc7_contin: + case tc7_subr_1: + case tc7_subr_2: + case tc7_subr_2o: + case tc7_cxr: + case tc7_subr_3: + case tc7_lsubr_2: + umwrongnumargs: + unmemocar(x, env); + wrongnumargs: + everr(x, env, proc, (char *)WNA, ""); + default: + goto badfun; + } + x = CDR(x); +#ifdef CAUTIOUS + if (IMP(x)) goto wrongnumargs; +#endif + t.arg1 = EVALCAR(x, env); + x = CDR(x); + if NULLP(x) +evap1: switch TYP7(proc) { /* have one argument in t.arg1 */ + case tc7_subr_2o: + return SUBRF(proc)(t.arg1, UNDEFINED); + case tc7_subr_1: + case tc7_subr_1o: + return SUBRF(proc)(t.arg1); + case tc7_cxr: +#ifdef FLOATS + if SUBRF(proc) { + if INUMP(t.arg1) + return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0); + ASRTGO(NIMP(t.arg1), floerr); + if REALP(t.arg1) + return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0); +# ifdef BIGDIG + if BIGP(t.arg1) + return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0); +# endif + floerr: + wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc))); + } +#endif + proc = (SCM)SNAME(proc); + { + char *chrs = CHARS(proc)+LENGTH(proc)-1; + while('c' != *--chrs) { + ASSERT(NIMP(t.arg1) && CONSP(t.arg1), + t.arg1, ARG1, CHARS(proc)); + t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1); + } + return t.arg1; + } + case tc7_rpsubr: + return BOOL_T; + case tc7_asubr: + return SUBRF(proc)(t.arg1, UNDEFINED); + case tc7_lsubr: + return SUBRF(proc)(cons(t.arg1, EOL)); +#ifdef CCLO + case tc7_cclo: + arg2 = t.arg1; + t.arg1 = proc; + proc = CCLO_SUBR(proc); + goto evap2; +#endif + case tcs_closures: + x = CODE(proc); + env = EXTEND_ENV(CAR(x), cons(t.arg1, EOL), ENV(proc)); + goto cdrtcdrxbegin; + case tc7_contin: + scm_dynthrow(CONT(proc), t.arg1); + case tc7_subr_2: + case tc7_subr_0: + case tc7_subr_3: + case tc7_lsubr_2: + goto wrongnumargs; + default: + goto badfun; + } +#ifdef CAUTIOUS + if (IMP(x)) goto wrongnumargs; +#endif + { /* have two or more arguments */ + arg2 = EVALCAR(x, env); + x = CDR(x); + if NULLP(x) +#ifdef CCLO + evap2: +#endif + switch TYP7(proc) { /* have two arguments */ + case tc7_subr_2: + case tc7_subr_2o: + return SUBRF(proc)(t.arg1, arg2); + case tc7_lsubr: + return SUBRF(proc)(cons2(t.arg1, arg2, EOL)); + case tc7_lsubr_2: + return SUBRF(proc)(t.arg1, arg2, EOL); + case tc7_rpsubr: + case tc7_asubr: + return SUBRF(proc)(t.arg1, arg2); +#ifdef CCLO + cclon: case tc7_cclo: + return apply(CCLO_SUBR(proc), proc, + cons2(t.arg1, arg2, cons(eval_args(x, env), EOL))); +/* case tc7_cclo: + x = cons(arg2, eval_args(x, env)); + arg2 = t.arg1; + t.arg1 = proc; + proc = CCLO_SUBR(proc); + goto evap3; */ +#endif + case tc7_subr_0: + case tc7_cxr: + case tc7_subr_1o: + case tc7_subr_1: + case tc7_subr_3: + case tc7_contin: + goto wrongnumargs; + default: + goto badfun; + case tcs_closures: + env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1, arg2, EOL), ENV(proc)); + x = CODE(proc); + goto cdrtcdrxbegin; + } + switch TYP7(proc) { /* have 3 or more arguments */ + case tc7_subr_3: + ASRTGO(NULLP(CDR(x)), wrongnumargs); + return SUBRF(proc)(t.arg1, arg2, EVALCAR(x, env)); + case tc7_asubr: +/* t.arg1 = SUBRF(proc)(t.arg1, arg2); + while NIMP(x) { + t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = CDR(x); + } + return t.arg1; */ + case tc7_rpsubr: + return apply(proc, t.arg1, acons(arg2, eval_args(x, env), EOL)); + case tc7_lsubr_2: + return SUBRF(proc)(t.arg1, arg2, eval_args(x, env)); + case tc7_lsubr: + return SUBRF(proc)(cons2(t.arg1, arg2, eval_args(x, env))); +#ifdef CCLO + case tc7_cclo: goto cclon; +#endif + case tcs_closures: + env = EXTEND_ENV(CAR(CODE(proc)), + cons2(t.arg1, arg2, eval_args(x, env)), + ENV(proc)); + x = CODE(proc); + goto cdrtcdrxbegin; + case tc7_subr_2: + case tc7_subr_1o: + case tc7_subr_2o: + case tc7_subr_0: + case tc7_cxr: + case tc7_subr_1: + case tc7_contin: + goto wrongnumargs; + default: + goto badfun; + } + } +} + +SCM procedurep(obj) + SCM obj; +{ + if NIMP(obj) switch TYP7(obj) { + case tcs_closures: + case tc7_contin: + case tcs_subrs: +#ifdef CCLO + case tc7_cclo: +#endif + return BOOL_T; + } + return BOOL_F; +} + +static char s_proc_doc[] = "procedure-documentation"; +SCM l_proc_doc(proc) + SCM proc; +{ + SCM code; + ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin, + proc, ARG1, s_proc_doc); + switch TYP7(proc) { + case tcs_closures: + code = CDR(CODE(proc)); + if IMP(CDR(code)) return BOOL_F; + code = CAR(code); + if IMP(code) return BOOL_F; + if STRINGP(code) return code; + default: + return BOOL_F; +/* + case tcs_subrs: +#ifdef CCLO + case tc7_cclo: +#endif +*/ + } +} + +/* This code is for apply. it is destructive on multiple args. + This will only screw you if you do (apply apply '( ... )) */ +SCM nconc2last(lst) + SCM lst; +{ + SCM *lloc = &lst; +#ifdef CAUTIOUS + ASSERT(ilength(lst) >= 1, lst, WNA, s_apply); +#endif + while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc); +#ifdef CAUTIOUS + ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply); +#endif + *lloc = CAR(*lloc); + return lst; +} + + +SCM apply(proc, arg1, args) + SCM proc, arg1, args; +{ + ASRTGO(NIMP(proc), badproc); + if NULLP(args) + if NULLP(arg1) arg1 = UNDEFINED; + else { + args = CDR(arg1); + arg1 = CAR(arg1); + } + else { + /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */ + args = nconc2last(args); + } +#ifdef CCLO + tail: +#endif + switch TYP7(proc) { + case tc7_subr_2o: + args = NULLP(args)?UNDEFINED:CAR(args); + return SUBRF(proc)(arg1, args); + case tc7_subr_2: + ASRTGO(NULLP(CDR(args)), wrongnumargs); + args = CAR(args); + return SUBRF(proc)(arg1, args); + case tc7_subr_0: + ASRTGO(UNBNDP(arg1), wrongnumargs); + return SUBRF(proc)(); + case tc7_subr_1: + case tc7_subr_1o: + ASRTGO(NULLP(args), wrongnumargs); + return SUBRF(proc)(arg1); + case tc7_cxr: + ASRTGO(NULLP(args), wrongnumargs); +#ifdef FLOATS + if SUBRF(proc) { + if INUMP(arg1) + return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0); + ASRTGO(NIMP(arg1), floerr); + if REALP(arg1) + return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0); +# ifdef BIGDIG + if BIGP(arg1) + return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0); +# endif + floerr: + wta(arg1, (char *)ARG1, CHARS(SNAME(proc))); + } +#endif + proc = (SCM)SNAME(proc); + { + char *chrs = CHARS(proc)+LENGTH(proc)-1; + while('c' != *--chrs) { + ASSERT(NIMP(arg1) && CONSP(arg1), + arg1, ARG1, CHARS(proc)); + arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1); + } + return arg1; + } + case tc7_subr_3: + return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args))); + case tc7_lsubr: + return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args)); + case tc7_lsubr_2: + ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); + return SUBRF(proc)(arg1, CAR(args), CDR(args)); + case tc7_asubr: + if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED); + while NIMP(args) { + ASSERT(CONSP(args), args, ARG2, s_apply); + arg1 = SUBRF(proc)(arg1, CAR(args)); + args = CDR(args); + } + return arg1; + case tc7_rpsubr: + if NULLP(args) return BOOL_T; + while NIMP(args) { + ASSERT(CONSP(args), args, ARG2, s_apply); + if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F; + arg1 = CAR(args); + args = CDR(args); + } + return BOOL_T; + case tcs_closures: + arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args)); +#ifndef RECKLESS + if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs; +#endif + args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc)); + proc = CODE(proc); + while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args); + return arg1; + case tc7_contin: + ASRTGO(NULLP(args), wrongnumargs); + scm_dynthrow(CONT(proc), arg1); +#ifdef CCLO + case tc7_cclo: + args = (UNBNDP(arg1) ? EOL : cons(arg1, args)); + arg1 = proc; + proc = CCLO_SUBR(proc); + goto tail; +#endif + wrongnumargs: + wta(proc, (char *)WNA, s_apply); + default: + badproc: + wta(proc, (char *)ARG1, s_apply); + return arg1; + } +} + +SCM map(proc, arg1, args) + SCM proc, arg1, args; +{ + long i; + SCM res = EOL, *pres = &res; + SCM *ve = &args; /* Keep args from being optimized away. */ + if NULLP(arg1) return res; + ASSERT(NIMP(arg1), arg1, ARG2, s_map); + if NULLP(args) { + while NIMP(arg1) { + ASSERT(CONSP(arg1), arg1, ARG2, s_map); + *pres = cons(apply(proc, CAR(arg1), listofnull), EOL); + pres = &CDR(*pres); + arg1 = CDR(arg1); + } + return res; + } + args = vector(cons(arg1, args)); + ve = VELTS(args); +#ifndef RECKLESS + for(i = LENGTH(args)-1; i >= 0; i--) + ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map); +#endif + while (1) { + arg1 = EOL; + for (i = LENGTH(args)-1;i >= 0;i--) { + if IMP(ve[i]) return res; + arg1 = cons(CAR(ve[i]), arg1); + ve[i] = CDR(ve[i]); + } + *pres = cons(apply(proc, arg1, EOL), EOL); + pres = &CDR(*pres); + } +} +SCM for_each(proc, arg1, args) + SCM proc, arg1, args; +{ + SCM *ve = &args; /* Keep args from being optimized away. */ + long i; + if NULLP(arg1) return UNSPECIFIED; + ASSERT(NIMP(arg1), arg1, ARG2, s_for_each); + if NULLP(args) { + while NIMP(arg1) { + ASSERT(CONSP(arg1), arg1, ARG2, s_for_each); + apply(proc, CAR(arg1), listofnull); + arg1 = CDR(arg1); + } + return UNSPECIFIED; + } + args = vector(cons(arg1, args)); + ve = VELTS(args); + while (1) { + arg1 = EOL; + for (i = LENGTH(args)-1;i >= 0;i--) { + if IMP(ve[i]) return UNSPECIFIED; + arg1 = cons(CAR(ve[i]), arg1); + ve[i] = CDR(ve[i]); + } + apply(proc, arg1, EOL); + } +} + +SCM closure(code, env) + SCM code, env; +{ + register SCM z; + NEWCELL(z); + SETCODE(z, code); + ENV(z) = env; + return z; +} + +long tc16_promise; +SCM makprom(code) + SCM code; +{ + register SCM z; + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_promise; + return z; +} +static int prinprom(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + lputs("#<promise ", port); + iprin1(CDR(exp), port, writing); + lputc('>', port); + return !0; +} + +SCM makacro(code) + SCM code; +{ + register SCM z; + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_macro; + return z; +} +SCM makmacro(code) + SCM code; +{ + register SCM z; + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_macro | (1L<<16); + return z; +} +SCM makmmacro(code) + SCM code; +{ + register SCM z; + NEWCELL(z); + CDR(z) = code; + CAR(z) = tc16_macro | (2L<<16); + return z; +} +static int prinmacro(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + if (CAR(exp) & (3L<<16)) lputs("#<macro", port); + else lputs("#<syntax", port); + if (CAR(exp) & (2L<<16)) lputc('!', port); + lputc(' ', port); + iprin1(CDR(exp), port, writing); + lputc('>', port); + return !0; +} + +char s_force[] = "force"; +SCM force(x) + SCM x; +{ + ASSERT((TYP16(x)==tc16_promise), x, ARG1, s_force); + if (!((1L<<16) & CAR(x))) { + SCM ans = apply(CDR(x), EOL, EOL); + if (!((1L<<16) & CAR(x))) { + DEFER_INTS; + CDR(x) = ans; + CAR(x) |= (1L<<16); + ALLOW_INTS; + } + } + return CDR(x); +} + +SCM copytree(obj) + SCM obj; +{ + SCM ans, tl; + if IMP(obj) return obj; + if VECTORP(obj) { + sizet i = LENGTH(obj); + ans = make_vector(MAKINUM(i), UNSPECIFIED); + while(i--) VELTS(ans)[i] = copytree(VELTS(obj)[i]); + return ans; + } + if NCONSP(obj) return obj; +/* return cons(copytree(CAR(obj)), copytree(CDR(obj))); */ + ans = tl = cons(copytree(CAR(obj)), UNSPECIFIED); + while(NIMP(obj = CDR(obj)) && CONSP(obj)) + tl = (CDR(tl) = cons(copytree(CAR(obj)), UNSPECIFIED)); + CDR(tl) = obj; + return ans; +} +SCM eval(obj) + SCM obj; +{ + obj = copytree(obj); + return EVAL(obj, (SCM)EOL); +} + +SCM definedp(x, env) + SCM x, env; +{ + SCM proc = CAR(x = CDR(x)); + return (ISYMP(proc) + || (NIMP(proc) && SYMBOLP(proc) + && !UNBNDP(CDR(sym2vcell(proc)))))? + (SCM)BOOL_T : (SCM)BOOL_F; +} + +static iproc subr1s[] = { + {"copy-tree", copytree}, + {s_eval, eval}, + {s_force, force}, + {s_proc_doc, l_proc_doc}, + {"procedure->syntax", makacro}, + {"procedure->macro", makmacro}, + {"procedure->memoizing-macro", makmmacro}, + {"apply:nconc-to-last", nconc2last}, + {0, 0}}; + +static iproc lsubr2s[] = { +/* {s_apply, apply}, now explicity initted */ + {s_map, map}, + {s_for_each, for_each}, + {0, 0}}; + +static smobfuns promsmob = {markcdr, free0, prinprom}; +static smobfuns macrosmob = {markcdr, free0, prinmacro}; + +SCM make_synt(name, macroizer, fcn) + char *name; + SCM (*macroizer)(); + SCM (*fcn)(); +{ + SCM symcell = sysintern(name, UNDEFINED); + long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); + register SCM z; + if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) + tmp = 0; + NEWCELL(z); + SUBRF(z) = fcn; + CAR(z) = tmp + tc7_subr_2; + CDR(symcell) = macroizer(z); + return CAR(symcell); +} + +void init_eval() +{ + tc16_promise = newsmob(&promsmob); + tc16_macro = newsmob(¯osmob); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(lsubr2s, tc7_lsubr_2); + i_apply = make_subr(s_apply, tc7_lsubr_2, apply); + i_dot = CAR(sysintern(".", UNDEFINED)); + i_arrow = CAR(sysintern("=>", UNDEFINED)); + i_else = CAR(sysintern("else", UNDEFINED)); + i_unquote = CAR(sysintern("unquote", UNDEFINED)); + i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED)); + + /* acros */ + i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote); + make_synt(s_define, makmmacro, m_define); + make_synt(s_delay, makacro, m_delay); + /* end of acros */ + + make_synt(s_and, makmmacro, m_and); + make_synt(s_begin, makmmacro, m_begin); + make_synt(s_case, makmmacro, m_case); + make_synt(s_cond, makmmacro, m_cond); + make_synt(s_do, makmmacro, m_do); + make_synt(s_if, makmmacro, m_if); + i_lambda = make_synt(s_lambda, makmmacro, m_lambda); + i_let = make_synt(s_let, makmmacro, m_let); + make_synt(s_letrec, makmmacro, m_letrec); + make_synt(s_letstar, makmmacro, m_letstar); + make_synt(s_or, makmmacro, m_or); + i_quote = make_synt(s_quote, makmmacro, m_quote); + make_synt(s_set, makmmacro, m_set); + make_synt(s_atapply, makmmacro, m_apply); + make_synt(s_atcall_cc, makmmacro, m_cont); + + make_synt("defined?", makacro, definedp); +} diff --git a/example.scm b/example.scm new file mode 100644 index 0000000..4a7b4a0 --- /dev/null +++ b/example.scm @@ -0,0 +1,137 @@ +;From Revised^4 Report on the Algorithmic Language Scheme +;William Clinger and Jonathon Rees (Editors) + +; EXAMPLE + +;INTEGRATE-SYSTEM integrates the system +; y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n +;of differential equations with the method of Runge-Kutta. + +;The parameter SYSTEM-DERIVATIVE is a function that takes a system +;state (a vector of values for the state variables y_1, ..., y_n) and +;produces a system derivative (the values y_1', ..., y_n'). The +;parameter INITIAL-STATE provides an initial system state, and H is an +;initial guess for the length of the integration step. + +;The value returned by INTEGRATE-SYSTEM is an infinite stream of +;system states. + +(define integrate-system + (lambda (system-derivative initial-state h) + (let ((next (runge-kutta-4 system-derivative h))) + (letrec ((states + (cons initial-state + (delay (map-streams next states))))) + states)))) + +;RUNGE-KUTTA-4 takes a function, F, that produces a +;system derivative from a system state. RUNGE-KUTTA-4 +;produces a function that takes a system state and +;produces a new system state. + +(define runge-kutta-4 + (lambda (f h) + (let ((*h (scale-vector h)) + (*2 (scale-vector 2)) + (*1/2 (scale-vector (/ 1 2))) + (*1/6 (scale-vector (/ 1 6)))) + (lambda (y) + ;; Y is a system state + (let* ((k0 (*h (f y))) + (k1 (*h (f (add-vectors y (*1/2 k0))))) + (k2 (*h (f (add-vectors y (*1/2 k1))))) + (k3 (*h (f (add-vectors y k2))))) + (add-vectors y + (*1/6 (add-vectors k0 + (*2 k1) + (*2 k2) + k3)))))))) + +(define elementwise + (lambda (f) + (lambda vectors + (generate-vector + (vector-length (car vectors)) + (lambda (i) + (apply f + (map (lambda (v) (vector-ref v i)) + vectors))))))) + +(define generate-vector + (lambda (size proc) + (let ((ans (make-vector size))) + (letrec ((loop + (lambda (i) + (cond ((= i size) ans) + (else + (vector-set! ans i (proc i)) + (loop (+ i 1))))))) + (loop 0))))) + +(define add-vectors (elementwise +)) + +(define scale-vector + (lambda (s) + (elementwise (lambda (x) (* x s))))) + +;MAP-STREAMS is analogous to MAP: it applies its first +;argument (a procedure) to all the elements of its second argument (a +;stream). + +(define map-streams + (lambda (f s) + (cons (f (head s)) + (delay (map-streams f (tail s)))))) + +;Infinite streams are implemented as pairs whose car holds the first +;element of the stream and whose cdr holds a promise to deliver the rest +;of the stream. + +(define head car) +(define tail + (lambda (stream) (force (cdr stream)))) + + +;The following illustrates the use of INTEGRATE-SYSTEM in +;integrating the system +; +; dvC vC +; C --- = -i - -- +; dt L R +; +; diL +; L --- = v +; dt C +; +;which models a damped oscillator. + +(define damped-oscillator + (lambda (R L C) + (lambda (state) + (let ((Vc (vector-ref state 0)) + (Il (vector-ref state 1))) + (vector (- 0 (+ (/ Vc (* R C)) (/ Il C))) + (/ Vc L)))))) + +(define the-states + (integrate-system + (damped-oscillator 10000 1000 .001) + '#(1 0) + .01)) + +(do ((i 10 (- i 1)) + (s the-states (tail s))) + ((zero? i) (newline)) + (newline) + (write (head s))) + +; #(1 0) +; #(0.99895054 9.994835e-6) +; #(0.99780226 1.9978681e-5) +; #(0.9965554 2.9950552e-5) +; #(0.9952102 3.990946e-5) +; #(0.99376684 4.985443e-5) +; #(0.99222565 5.9784474e-5) +; #(0.9905868 6.969862e-5) +; #(0.9888506 7.9595884e-5) +; #(0.9870173 8.94753e-5) diff --git a/findexec.c b/findexec.c new file mode 100644 index 0000000..bbeac76 --- /dev/null +++ b/findexec.c @@ -0,0 +1,145 @@ +/* This file was part of DLD, a dynamic link/unlink editor for C. + + Copyright (C) 1990 by W. Wilson Ho. + + The author can be reached electronically by how@cs.ucdavis.edu or + through physical mail at: + + W. Wilson Ho + Division of Computer Science + University of California at Davis + Davis, CA 95616 + +Fri Sep 14 22:16:14 1990 Edgar Roeder (edgar at megamaster) + + * added a separate DLDPATH environment variable in + dld_find_executable so that users may specify a special path + for object modules. + +Thu Feb 3 01:46:16 1994 Aubrey Jaffer (jaffer@jacal) + + * find_exec.c (dld_find_executable): added stat check for + linux so that it doesn't think directories with the same name + as the program are executable. + +Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics> + + * find_exec.c: extracted for general use. Generalized to + MS-DOS. */ + +/* This program is free software; you can 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. */ + +/* Given a filename, dld_find_executable searches the directories + listed in the environment variable PATH for a file with that + filename. A new copy of the complete path name of that file is + returned. This new string may be disposed by free() later on. */ + +#include <sys/file.h> +#include <sys/param.h> +#ifdef linux +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> /* for X_OK define */ +#endif +#ifdef __svr4__ +# include <string.h> +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> /* for X_OK define */ +#else +# ifdef __sgi__ +# include <string.h> +# include <stdlib.h> +# include <sys/stat.h> +# include <unistd.h> /* for X_OK define */ +# else +# include <strings.h> +# endif +#endif +#ifndef __STDC__ +# define const /**/ +#endif + +#ifndef DEFAULT_PATH +# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts" +#endif + +static char *copy_of(s) + register const char *s; +{ + register char *p = (char *) malloc(strlen(s)+1); + if (!p) return 0; + *p = 0; + strcpy(p, s); + return p; +} + +/* ABSOLUTE_FILENAME_P(fname): True if fname is an absolute filename */ +#ifdef atarist +# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') || \ + (fname[0] && (fname[1] == ':'))) +#else +# define ABSOLUTE_FILENAME_P(fname) (fname[0] == '/') +#endif /* atarist */ + +char *dld_find_executable(name) + const char *name; +{ + char *search; + register char *p; + char tbuf[MAXPATHLEN]; + + if (ABSOLUTE_FILENAME_P(name)) + return copy_of(name); + + if ((name[0] == '.') && (name[1] == '/')) { + getcwd(tbuf, MAXPATHLEN); + strcat(tbuf, name + 1); + return copy_of(tbuf); + } + + if (((search = (char *) getenv("DLDPATH")) == 0) && + ((search = (char *) getenv("PATH")) == 0)) + search = DEFAULT_PATH; + + p = search; + + while (*p) { + register char *next = tbuf; + + if (p[0]=='~' && p[1]=='/' && getenv("HOME")) { + strcpy(tbuf, (char *)getenv("HOME")); + next = tbuf + strlen(tbuf); + p++; + } + + /* Copy directory name into [tbuf] */ + while (*p && *p != ':') *next++ = *p++; + *next = 0; + if (*p) p++; + + if (tbuf[0] == '.' && tbuf[1] == 0) + getcwd(tbuf, MAXPATHLEN); /* was getwd(tbuf); */ + else if (tbuf[0]=='~' && tbuf[1]==0 && getenv("HOME")) + strcpy(tbuf, (char *)getenv("HOME")); + + strcat(tbuf, "/"); + strcat(tbuf, name); + + if (access(tbuf, X_OK) == 0) { +#ifndef hpux +# ifndef ultrix + struct stat stat_temp; + if (stat(tbuf,&stat_temp)) continue; + if (S_IFREG != (S_IFMT & stat_temp.st_mode)) continue; +# endif/* ultrix */ +#endif /* hpux */ + return copy_of(tbuf); + } + } + + return 0; +} diff --git a/gmalloc.c b/gmalloc.c new file mode 100644 index 0000000..59874ee --- /dev/null +++ b/gmalloc.c @@ -0,0 +1,1638 @@ +/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */ + +#define _MALLOC_INTERNAL + +/* The malloc headers and source files from the C library follow here. */ + +/* Declarations for `malloc' and friends. + Copyright 1990, 91, 92, 93, 95, 96 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_H + +#define _MALLOC_H 1 + +#ifdef _MALLOC_INTERNAL + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) +#undef __P +#define __P(args) args +#undef __ptr_t +#define __ptr_t void * +#else /* Not C++ or ANSI C. */ +#undef __P +#define __P(args) () +#undef const +#define const +#undef __ptr_t +#define __ptr_t char * +#endif /* C++ or ANSI C. */ + +#if defined(_LIBC) || defined(STDC_HEADERS) || defined(USG) +#include <string.h> +#else +#ifndef memset +#define memset(s, zero, n) bzero ((s), (n)) +#endif +#ifndef memcpy +#define memcpy(d, s, n) bcopy ((s), (d), (n)) +#endif +#endif + +#if defined (__GNU_LIBRARY__) || (defined (__STDC__) && __STDC__) +#include <limits.h> +#else +#ifndef CHAR_BIT +#define CHAR_BIT 8 +#endif +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#endif /* _MALLOC_INTERNAL. */ + + +#ifdef __cplusplus +extern "C" +{ +#endif + +#if defined (__STDC__) && __STDC__ +#include <stddef.h> +#define __malloc_size_t size_t +#define __malloc_ptrdiff_t ptrdiff_t +#else +#define __malloc_size_t unsigned int +#define __malloc_ptrdiff_t int +#endif + +#ifndef NULL +#define NULL 0 +#endif + + +/* Allocate SIZE bytes of memory. */ +extern __ptr_t malloc __P ((__malloc_size_t __size)); +/* Re-allocate the previously allocated block + in __ptr_t, making the new block SIZE bytes long. */ +extern __ptr_t realloc __P ((__ptr_t __ptr, __malloc_size_t __size)); +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ +extern __ptr_t calloc __P ((__malloc_size_t __nmemb, __malloc_size_t __size)); +/* Free a block allocated by `malloc', `realloc' or `calloc'. */ +extern void free __P ((__ptr_t __ptr)); + +/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ +#if ! (defined (_MALLOC_INTERNAL) && __DJGPP__ - 0 == 1) /* Avoid conflict. */ +extern __ptr_t memalign __P ((__malloc_size_t __alignment, + __malloc_size_t __size)); +#endif + +/* Allocate SIZE bytes on a page boundary. */ +#if ! (defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC)) +extern __ptr_t valloc __P ((__malloc_size_t __size)); +#endif + + +#ifdef _MALLOC_INTERNAL + +/* The allocator divides the heap into blocks of fixed size; large + requests receive one or more whole blocks, and small requests + receive a fragment of a block. Fragment sizes are powers of two, + and all fragments of a block are the same size. When all the + fragments in a block have been freed, the block itself is freed. */ +#define INT_BIT (CHAR_BIT * sizeof(int)) +#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) +#define BLOCKSIZE (1 << BLOCKLOG) +#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) + +/* Determine the amount of memory spanned by the initial heap table + (not an absolute limit). */ +#define HEAP (INT_BIT > 16 ? 4194304 : 65536) + +/* Number of contiguous free blocks allowed to build up at the end of + memory before they will be returned to the system. */ +#define FINAL_FREE_BLOCKS 8 + +/* Data structure giving per-block information. */ +typedef union + { + /* Heap information for a busy block. */ + struct + { + /* Zero for a large (multiblock) object, or positive giving the + logarithm to the base two of the fragment size. */ + int type; + union + { + struct + { + __malloc_size_t nfree; /* Free frags in a fragmented block. */ + __malloc_size_t first; /* First free fragment of the block. */ + } frag; + /* For a large object, in its first block, this has the number + of blocks in the object. In the other blocks, this has a + negative number which says how far back the first block is. */ + __malloc_ptrdiff_t size; + } info; + } busy; + /* Heap information for a free block + (that may be the first of a free cluster). */ + struct + { + __malloc_size_t size; /* Size (in blocks) of a free cluster. */ + __malloc_size_t next; /* Index of next free cluster. */ + __malloc_size_t prev; /* Index of previous free cluster. */ + } free; + } malloc_info; + +/* Pointer to first block of the heap. */ +extern char *_heapbase; + +/* Table indexed by block number giving per-block information. */ +extern malloc_info *_heapinfo; + +/* Address to block number and vice versa. */ +#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) +#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase)) + +/* Current search index for the heap table. */ +extern __malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +extern __malloc_size_t _heaplimit; + +/* Doubly linked lists of free fragments. */ +struct list + { + struct list *next; + struct list *prev; + }; + +/* Free list headers for each fragment size. */ +extern struct list _fraghead[]; + +/* List of blocks allocated with `memalign' (or `valloc'). */ +struct alignlist + { + struct alignlist *next; + __ptr_t aligned; /* The address that memaligned returned. */ + __ptr_t exact; /* The address that malloc returned. */ + }; +extern struct alignlist *_aligned_blocks; + +/* Instrumentation. */ +extern __malloc_size_t _chunks_used; +extern __malloc_size_t _bytes_used; +extern __malloc_size_t _chunks_free; +extern __malloc_size_t _bytes_free; + +/* Internal versions of `malloc', `realloc', and `free' + used when these functions need to call each other. + They are the same but don't call the hooks. */ +extern __ptr_t _malloc_internal __P ((__malloc_size_t __size)); +extern __ptr_t _realloc_internal __P ((__ptr_t __ptr, __malloc_size_t __size)); +extern void _free_internal __P ((__ptr_t __ptr)); + +#endif /* _MALLOC_INTERNAL. */ + +/* Given an address in the middle of a malloc'd object, + return the address of the beginning of the object. */ +extern __ptr_t malloc_find_object_address __P ((__ptr_t __ptr)); + +/* Underlying allocation function; successive calls should + return contiguous pieces of memory. */ +extern __ptr_t (*__morecore) __P ((__malloc_ptrdiff_t __size)); + +/* Default value of `__morecore'. */ +extern __ptr_t __default_morecore __P ((__malloc_ptrdiff_t __size)); + +/* If not NULL, this function is called after each time + `__morecore' is called to increase the data size. */ +extern void (*__after_morecore_hook) __P ((void)); + +/* Number of extra blocks to get each time we ask for more core. + This reduces the frequency of calling `(*__morecore)'. */ +extern __malloc_size_t __malloc_extra_blocks; + +/* Nonzero if `malloc' has been called and done its initialization. */ +extern int __malloc_initialized; +/* Function called to initialize malloc data structures. */ +extern int __malloc_initialize __P ((void)); + +/* Hooks for debugging versions. */ +extern void (*__malloc_initialize_hook) __P ((void)); +extern void (*__free_hook) __P ((__ptr_t __ptr)); +extern __ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); +extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); +extern __ptr_t (*__memalign_hook) __P ((__malloc_size_t __size, + __malloc_size_t __alignment)); + +/* Return values for `mprobe': these are the kinds of inconsistencies that + `mcheck' enables detection of. */ +enum mcheck_status + { + MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */ + MCHECK_OK, /* Block is fine. */ + MCHECK_FREE, /* Block freed twice. */ + MCHECK_HEAD, /* Memory before the block was clobbered. */ + MCHECK_TAIL /* Memory after the block was clobbered. */ + }; + +/* Activate a standard collection of debugging hooks. This must be called + before `malloc' is ever called. ABORTFUNC is called with an error code + (see enum above) when an inconsistency is detected. If ABORTFUNC is + null, the standard function prints on stderr and then calls `abort'. */ +extern int mcheck __P ((void (*__abortfunc) __P ((enum mcheck_status)))); + +/* Check for aberrations in a particular malloc'd block. You must have + called `mcheck' already. These are the same checks that `mcheck' does + when you free or reallocate a block. */ +extern enum mcheck_status mprobe __P ((__ptr_t __ptr)); + +/* Activate a standard collection of tracing hooks. */ +extern void mtrace __P ((void)); +extern void muntrace __P ((void)); + +/* Statistics available to the user. */ +struct mstats + { + __malloc_size_t bytes_total; /* Total size of the heap. */ + __malloc_size_t chunks_used; /* Chunks allocated by the user. */ + __malloc_size_t bytes_used; /* Byte total of user-allocated chunks. */ + __malloc_size_t chunks_free; /* Chunks in the free list. */ + __malloc_size_t bytes_free; /* Byte total of chunks in the free list. */ + }; + +/* Pick up the current statistics. */ +extern struct mstats mstats __P ((void)); + +/* Call WARNFUN with a warning message when memory usage is high. */ +extern void memory_warnings __P ((__ptr_t __start, + void (*__warnfun) __P ((const char *)))); + + +/* Relocating allocator. */ + +/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */ +extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + +/* Free the storage allocated in HANDLEPTR. */ +extern void r_alloc_free __P ((__ptr_t *__handleptr)); + +/* Adjust the block at HANDLEPTR to be SIZE bytes long. */ +extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size)); + + +#ifdef __cplusplus +} +#endif + +#endif /* malloc.h */ +/* Memory allocator `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif +#include <errno.h> + +/* How to really get more memory. */ +__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore; + +/* Debugging hook for `malloc'. */ +__ptr_t (*__malloc_hook) __P ((__malloc_size_t __size)); + +/* Pointer to the base of the first block. */ +char *_heapbase; + +/* Block information table. Allocated with align/__free (not malloc/free). */ +malloc_info *_heapinfo; + +/* Number of info entries. */ +static __malloc_size_t heapsize; + +/* Search index in the info table. */ +__malloc_size_t _heapindex; + +/* Limit of valid info table indices. */ +__malloc_size_t _heaplimit; + +/* Free lists for each fragment size. */ +struct list _fraghead[BLOCKLOG]; + +/* Instrumentation. */ +__malloc_size_t _chunks_used; +__malloc_size_t _bytes_used; +__malloc_size_t _chunks_free; +__malloc_size_t _bytes_free; + +/* Are you experienced? */ +int __malloc_initialized; + +__malloc_size_t __malloc_extra_blocks; + +void (*__malloc_initialize_hook) __P ((void)); +void (*__after_morecore_hook) __P ((void)); + + +/* Aligned allocation. */ +static __ptr_t align __P ((__malloc_size_t)); +static __ptr_t +align (size) + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj; + + result = (*__morecore) (size); + adj = (unsigned long int) ((unsigned long int) ((char *) result - + (char *) NULL)) % BLOCKSIZE; + if (adj != 0) + { + __ptr_t new; + adj = BLOCKSIZE - adj; + new = (*__morecore) (adj); + result = (char *) result + adj; + } + + if (__after_morecore_hook) + (*__after_morecore_hook) (); + + return result; +} + +/* Get SIZE bytes, if we can get them starting at END. + Return the address of the space we got. + If we cannot get space at END, fail and return 0. */ +static __ptr_t get_contiguous_space __P ((__malloc_ptrdiff_t, __ptr_t)); +static __ptr_t +get_contiguous_space (size, position) + __malloc_ptrdiff_t size; + __ptr_t position; +{ + __ptr_t before; + __ptr_t after; + + before = (*__morecore) (0); + /* If we can tell in advance that the break is at the wrong place, + fail now. */ + if (before != position) + return 0; + + /* Allocate SIZE bytes and get the address of them. */ + after = (*__morecore) (size); + if (!after) + return 0; + + /* It was not contiguous--reject it. */ + if (after != position) + { + (*__morecore) (- size); + return 0; + } + + return after; +} + + +/* This is called when `_heapinfo' and `heapsize' have just + been set to describe a new info table. Set up the table + to describe itself and account for it in the statistics. */ +static void register_heapinfo __P ((void)); +#ifdef __GNUC__ +__inline__ +#endif +static void +register_heapinfo () +{ + __malloc_size_t block, blocks; + + block = BLOCK (_heapinfo); + blocks = BLOCKIFY (heapsize * sizeof (malloc_info)); + + /* Account for the _heapinfo block itself in the statistics. */ + _bytes_used += blocks * BLOCKSIZE; + ++_chunks_used; + + /* Describe the heapinfo block itself in the heapinfo. */ + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + /* Leave back-pointers for malloc_find_address. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; +} + +/* Set everything up and remember that we have. */ +int +__malloc_initialize () +{ + if (__malloc_initialized) + return 0; + + if (__malloc_initialize_hook) + (*__malloc_initialize_hook) (); + + heapsize = HEAP / BLOCKSIZE; + _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info)); + if (_heapinfo == NULL) + return 0; + memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); + _heapinfo[0].free.size = 0; + _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; + _heapindex = 0; + _heapbase = (char *) _heapinfo; + _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); + + register_heapinfo (); + + __malloc_initialized = 1; + return 1; +} + +static int morecore_recursing; + +/* Get neatly aligned memory, initializing or + growing the heap info table as necessary. */ +static __ptr_t morecore __P ((__malloc_size_t)); +static __ptr_t +morecore (size) + __malloc_size_t size; +{ + __ptr_t result; + malloc_info *newinfo, *oldinfo; + __malloc_size_t newsize; + + if (morecore_recursing) + /* Avoid recursion. The caller will know how to handle a null return. */ + return NULL; + + result = align (size); + if (result == NULL) + return NULL; + + /* Check if we need to grow the info table. */ + if ((__malloc_size_t) BLOCK ((char *) result + size) > heapsize) + { + /* Calculate the new _heapinfo table size. We do not account for the + added blocks in the table itself, as we hope to place them in + existing free space, which is already covered by part of the + existing table. */ + newsize = heapsize; + do + newsize *= 2; + while ((__malloc_size_t) BLOCK ((char *) result + size) > newsize); + + /* We must not reuse existing core for the new info table when called + from realloc in the case of growing a large block, because the + block being grown is momentarily marked as free. In this case + _heaplimit is zero so we know not to reuse space for internal + allocation. */ + if (_heaplimit != 0) + { + /* First try to allocate the new info table in core we already + have, in the usual way using realloc. If realloc cannot + extend it in place or relocate it to existing sufficient core, + we will get called again, and the code above will notice the + `morecore_recursing' flag and return null. */ + int save = errno; /* Don't want to clobber errno with ENOMEM. */ + morecore_recursing = 1; + newinfo = (malloc_info *) _realloc_internal + (_heapinfo, newsize * sizeof (malloc_info)); + morecore_recursing = 0; + if (newinfo == NULL) + errno = save; + else + { + /* We found some space in core, and realloc has put the old + table's blocks on the free list. Now zero the new part + of the table and install the new table location. */ + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + _heapinfo = newinfo; + heapsize = newsize; + goto got_heap; + } + } + + /* Allocate new space for the malloc info table. */ + while (1) + { + newinfo = (malloc_info *) align (newsize * sizeof (malloc_info)); + + /* Did it fail? */ + if (newinfo == NULL) + { + (*__morecore) (-size); + return NULL; + } + + /* Is it big enough to record status for its own space? + If so, we win. */ + if ((__malloc_size_t) BLOCK ((char *) newinfo + + newsize * sizeof (malloc_info)) + < newsize) + break; + + /* Must try again. First give back most of what we just got. */ + (*__morecore) (- newsize * sizeof (malloc_info)); + newsize *= 2; + } + + /* Copy the old table to the beginning of the new, + and zero the rest of the new table. */ + memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); + memset (&newinfo[heapsize], 0, + (newsize - heapsize) * sizeof (malloc_info)); + oldinfo = _heapinfo; + _heapinfo = newinfo; + heapsize = newsize; + + register_heapinfo (); + + /* Reset _heaplimit so _free_internal never decides + it can relocate or resize the info table. */ + _heaplimit = 0; + _free_internal (oldinfo); + + /* The new heap limit includes the new table just allocated. */ + _heaplimit = BLOCK ((char *) newinfo + heapsize * sizeof (malloc_info)); + return result; + } + + got_heap: + _heaplimit = BLOCK ((char *) result + size); + return result; +} + +/* Allocate memory from the heap. */ +__ptr_t +_malloc_internal (size) + __malloc_size_t size; +{ + __ptr_t result; + __malloc_size_t block, blocks, lastblocks, start; + register __malloc_size_t i; + struct list *next; + + /* ANSI C allows `malloc (0)' to either return NULL, or to return a + valid address you can realloc and free (though not dereference). + + It turns out that some extant code (sunrpc, at least Ultrix's version) + expects `malloc (0)' to return non-NULL and breaks otherwise. + Be compatible. */ + +#if 0 + if (size == 0) + return NULL; +#endif + + if (size < sizeof (struct list)) + size = sizeof (struct list); + +#ifdef SUNOS_LOCALTIME_BUG + if (size < 16) + size = 16; +#endif + + /* Determine the allocation policy based on the request size. */ + if (size <= BLOCKSIZE / 2) + { + /* Small allocation to receive a fragment of a block. + Determine the logarithm to base two of the fragment size. */ + register __malloc_size_t log = 1; + --size; + while ((size /= 2) != 0) + ++log; + + /* Look in the fragment lists for a + free fragment of the desired size. */ + next = _fraghead[log].next; + if (next != NULL) + { + /* There are free fragments of this size. + Pop a fragment out of the fragment list and return it. + Update the block's nfree and first counters. */ + result = (__ptr_t) next; + next->prev->next = next->next; + if (next->next != NULL) + next->next->prev = next->prev; + block = BLOCK (result); + if (--_heapinfo[block].busy.info.frag.nfree != 0) + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) next->next - (char *) NULL) + % BLOCKSIZE) >> log; + + /* Update the statistics. */ + ++_chunks_used; + _bytes_used += 1 << log; + --_chunks_free; + _bytes_free -= 1 << log; + } + else + { + /* No free fragments of the desired size, so get a new block + and break it into fragments, returning the first. */ + result = malloc (BLOCKSIZE); + if (result == NULL) + return NULL; + + /* Link all fragments but the first into the free list. */ + next = (struct list *) ((char *) result + (1 << log)); + next->next = NULL; + next->prev = &_fraghead[log]; + _fraghead[log].next = next; + + for (i = 2; i < (__malloc_size_t) (BLOCKSIZE >> log); ++i) + { + next = (struct list *) ((char *) result + (i << log)); + next->next = _fraghead[log].next; + next->prev = &_fraghead[log]; + next->prev->next = next; + next->next->prev = next; + } + + /* Initialize the nfree and first counters for this block. */ + block = BLOCK (result); + _heapinfo[block].busy.type = log; + _heapinfo[block].busy.info.frag.nfree = i - 1; + _heapinfo[block].busy.info.frag.first = i - 1; + + _chunks_free += (BLOCKSIZE >> log) - 1; + _bytes_free += BLOCKSIZE - (1 << log); + _bytes_used -= BLOCKSIZE - (1 << log); + } + } + else + { + /* Large allocation to receive one or more blocks. + Search the free list in a circle starting at the last place visited. + If we loop completely around without finding a large enough + space we will have to get more memory from the system. */ + blocks = BLOCKIFY (size); + start = block = _heapindex; + while (_heapinfo[block].free.size < blocks) + { + block = _heapinfo[block].free.next; + if (block == start) + { + /* Need to get more from the system. Get a little extra. */ + __malloc_size_t wantblocks = blocks + __malloc_extra_blocks; + block = _heapinfo[0].free.prev; + lastblocks = _heapinfo[block].free.size; + /* Check to see if the new core will be contiguous with the + final free block; if so we don't need to get as much. */ + if (_heaplimit != 0 && block + lastblocks == _heaplimit && + /* We can't do this if we will have to make the heap info + table bigger to accomodate the new space. */ + block + wantblocks <= heapsize && + get_contiguous_space ((wantblocks - lastblocks) * BLOCKSIZE, + ADDRESS (block + lastblocks))) + { + /* We got it contiguously. Which block we are extending + (the `final free block' referred to above) might have + changed, if it got combined with a freed info table. */ + block = _heapinfo[0].free.prev; + _heapinfo[block].free.size += (wantblocks - lastblocks); + _bytes_free += (wantblocks - lastblocks) * BLOCKSIZE; + _heaplimit += wantblocks - lastblocks; + continue; + } + result = morecore (wantblocks * BLOCKSIZE); + if (result == NULL) + return NULL; + block = BLOCK (result); + /* Put the new block at the end of the free list. */ + _heapinfo[block].free.size = wantblocks; + _heapinfo[block].free.prev = _heapinfo[0].free.prev; + _heapinfo[block].free.next = 0; + _heapinfo[0].free.prev = block; + _heapinfo[_heapinfo[block].free.prev].free.next = block; + ++_chunks_free; + /* Now loop to use some of that block for this allocation. */ + } + } + + /* At this point we have found a suitable free list entry. + Figure out how to remove what we need from the list. */ + result = ADDRESS (block); + if (_heapinfo[block].free.size > blocks) + { + /* The block we found has a bit left over, + so relink the tail end back into the free list. */ + _heapinfo[block + blocks].free.size + = _heapinfo[block].free.size - blocks; + _heapinfo[block + blocks].free.next + = _heapinfo[block].free.next; + _heapinfo[block + blocks].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[_heapinfo[block].free.next].free.prev + = _heapindex = block + blocks; + } + else + { + /* The block exactly matches our requirements, + so just remove it from the list. */ + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapindex = _heapinfo[block].free.next; + --_chunks_free; + } + + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = blocks; + ++_chunks_used; + _bytes_used += blocks * BLOCKSIZE; + _bytes_free -= blocks * BLOCKSIZE; + + /* Mark all the blocks of the object just allocated except for the + first with a negative number so you can find the first block by + adding that adjustment. */ + while (--blocks > 0) + _heapinfo[block + blocks].busy.info.size = -blocks; + } + + return result; +} + +__ptr_t +malloc (size) + __malloc_size_t size; +{ + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + return (__malloc_hook != NULL ? *__malloc_hook : _malloc_internal) (size); +} + +#ifndef _LIBC + +/* On some ANSI C systems, some libc functions call _malloc, _free + and _realloc. Make them use the GNU functions. */ + +__ptr_t +_malloc (size) + __malloc_size_t size; +{ + return malloc (size); +} + +void +_free (ptr) + __ptr_t ptr; +{ + free (ptr); +} + +__ptr_t +_realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + return realloc (ptr, size); +} + +#endif +/* Free a block of memory allocated by `malloc'. + Copyright 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + + +/* Cope with systems lacking `memmove'. */ +#ifndef memmove +#if (defined (MEMMOVE_MISSING) || \ + !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG)) +#ifdef emacs +#undef __malloc_safe_bcopy +#define __malloc_safe_bcopy safe_bcopy +#endif +/* This function is defined in realloc.c. */ +extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t)); +#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size)) +#endif +#endif + + +/* Debugging hook for free. */ +void (*__free_hook) __P ((__ptr_t __ptr)); + +/* List of blocks allocated by memalign. */ +struct alignlist *_aligned_blocks = NULL; + +/* Return memory to the heap. + Like `free' but don't call a __free_hook if there is one. */ +void +_free_internal (ptr) + __ptr_t ptr; +{ + int type; + __malloc_size_t block, blocks; + register __malloc_size_t i; + struct list *prev, *next; + __ptr_t curbrk; + const __malloc_size_t lesscore_threshold + /* Threshold of free space at which we will return some to the system. */ + = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks; + + register struct alignlist *l; + + if (ptr == NULL) + return; + + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == ptr) + { + l->aligned = NULL; /* Mark the slot in the list as free. */ + ptr = l->exact; + break; + } + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Get as many statistics as early as we can. */ + --_chunks_used; + _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; + _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; + + /* Find the free cluster previous to this one in the free list. + Start searching at the last block referenced; this may benefit + programs with locality of allocation. */ + i = _heapindex; + if (i > block) + while (i > block) + i = _heapinfo[i].free.prev; + else + { + do + i = _heapinfo[i].free.next; + while (i > 0 && i < block); + i = _heapinfo[i].free.prev; + } + + /* Determine how to link this block into the free list. */ + if (block == i + _heapinfo[i].free.size) + { + /* Coalesce this block with its predecessor. */ + _heapinfo[i].free.size += _heapinfo[block].busy.info.size; + block = i; + } + else + { + /* Really link this block back into the free list. */ + _heapinfo[block].free.size = _heapinfo[block].busy.info.size; + _heapinfo[block].free.next = _heapinfo[i].free.next; + _heapinfo[block].free.prev = i; + _heapinfo[i].free.next = block; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + ++_chunks_free; + } + + /* Now that the block is linked in, see if we can coalesce it + with its successor (by deleting its successor from the list + and adding in its size). */ + if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) + { + _heapinfo[block].free.size + += _heapinfo[_heapinfo[block].free.next].free.size; + _heapinfo[block].free.next + = _heapinfo[_heapinfo[block].free.next].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev = block; + --_chunks_free; + } + + /* How many trailing free blocks are there now? */ + blocks = _heapinfo[block].free.size; + + /* Where is the current end of accessible core? */ + curbrk = (*__morecore) (0); + + if (_heaplimit != 0 && curbrk == ADDRESS (_heaplimit)) + { + /* The end of the malloc heap is at the end of accessible core. + It's possible that moving _heapinfo will allow us to + return some space to the system. */ + + __malloc_size_t info_block = BLOCK (_heapinfo); + __malloc_size_t info_blocks = _heapinfo[info_block].busy.info.size; + __malloc_size_t prev_block = _heapinfo[block].free.prev; + __malloc_size_t prev_blocks = _heapinfo[prev_block].free.size; + __malloc_size_t next_block = _heapinfo[block].free.next; + __malloc_size_t next_blocks = _heapinfo[next_block].free.size; + + if (/* Win if this block being freed is last in core, the info table + is just before it, the previous free block is just before the + info table, and the two free blocks together form a useful + amount to return to the system. */ + (block + blocks == _heaplimit && + info_block + info_blocks == block && + prev_block != 0 && prev_block + prev_blocks == info_block && + blocks + prev_blocks >= lesscore_threshold) || + /* Nope, not the case. We can also win if this block being + freed is just before the info table, and the table extends + to the end of core or is followed only by a free block, + and the total free space is worth returning to the system. */ + (block + blocks == info_block && + ((info_block + info_blocks == _heaplimit && + blocks >= lesscore_threshold) || + (info_block + info_blocks == next_block && + next_block + next_blocks == _heaplimit && + blocks + next_blocks >= lesscore_threshold))) + ) + { + malloc_info *newinfo; + __malloc_size_t oldlimit = _heaplimit; + + /* Free the old info table, clearing _heaplimit to avoid + recursion into this code. We don't want to return the + table's blocks to the system before we have copied them to + the new location. */ + _heaplimit = 0; + _free_internal (_heapinfo); + _heaplimit = oldlimit; + + /* Tell malloc to search from the beginning of the heap for + free blocks, so it doesn't reuse the ones just freed. */ + _heapindex = 0; + + /* Allocate new space for the info table and move its data. */ + newinfo = (malloc_info *) _malloc_internal (info_blocks + * BLOCKSIZE); + memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE); + _heapinfo = newinfo; + + /* We should now have coalesced the free block with the + blocks freed from the old info table. Examine the entire + trailing free block to decide below whether to return some + to the system. */ + block = _heapinfo[0].free.prev; + blocks = _heapinfo[block].free.size; + } + + /* Now see if we can return stuff to the system. */ + if (block + blocks == _heaplimit && blocks >= lesscore_threshold) + { + register __malloc_size_t bytes = blocks * BLOCKSIZE; + _heaplimit -= blocks; + (*__morecore) (-bytes); + _heapinfo[_heapinfo[block].free.prev].free.next + = _heapinfo[block].free.next; + _heapinfo[_heapinfo[block].free.next].free.prev + = _heapinfo[block].free.prev; + block = _heapinfo[block].free.prev; + --_chunks_free; + _bytes_free -= bytes; + } + } + + /* Set the next search to begin at this block. */ + _heapindex = block; + break; + + default: + /* Do some of the statistics. */ + --_chunks_used; + _bytes_used -= 1 << type; + ++_chunks_free; + _bytes_free += 1 << type; + + /* Get the address of the first free fragment in this block. */ + prev = (struct list *) ((char *) ADDRESS (block) + + (_heapinfo[block].busy.info.frag.first << type)); + + if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) + { + /* If all fragments of this block are free, remove them + from the fragment list and free the whole block. */ + next = prev; + for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> type); ++i) + next = next->next; + prev->prev->next = next; + if (next != NULL) + next->prev = prev->prev; + _heapinfo[block].busy.type = 0; + _heapinfo[block].busy.info.size = 1; + + /* Keep the statistics accurate. */ + ++_chunks_used; + _bytes_used += BLOCKSIZE; + _chunks_free -= BLOCKSIZE >> type; + _bytes_free -= BLOCKSIZE; + + free (ADDRESS (block)); + } + else if (_heapinfo[block].busy.info.frag.nfree != 0) + { + /* If some fragments of this block are free, link this + fragment into the fragment list after the first free + fragment of this block. */ + next = (struct list *) ptr; + next->next = prev->next; + next->prev = prev; + prev->next = next; + if (next->next != NULL) + next->next->prev = next; + ++_heapinfo[block].busy.info.frag.nfree; + } + else + { + /* No fragments of this block are free, so link this + fragment into the fragment list and announce that + it is the first free fragment of this block. */ + prev = (struct list *) ptr; + _heapinfo[block].busy.info.frag.nfree = 1; + _heapinfo[block].busy.info.frag.first = (unsigned long int) + ((unsigned long int) ((char *) ptr - (char *) NULL) + % BLOCKSIZE >> type); + prev->next = _fraghead[type].next; + prev->prev = &_fraghead[type]; + prev->prev->next = prev; + if (prev->next != NULL) + prev->next->prev = prev; + } + break; + } +} + +/* Return memory to the heap. */ +void +free (ptr) + __ptr_t ptr; +{ + if (__free_hook != NULL) + (*__free_hook) (ptr); + else + _free_internal (ptr); +} + +/* Define the `cfree' alias for `free'. */ +#ifdef weak_alias +weak_alias (free, cfree) +#else +void +cfree (ptr) + __ptr_t ptr; +{ + free (ptr); +} +#endif +/* Change the size of a block allocated by `malloc'. + Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Written May 1989 by Mike Haertel. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + + + +/* Cope with systems lacking `memmove'. */ +#if (defined (MEMMOVE_MISSING) || \ + !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG)) + +#ifdef emacs +#undef __malloc_safe_bcopy +#define __malloc_safe_bcopy safe_bcopy +#else + +/* Snarfed directly from Emacs src/dispnew.c: + XXX Should use system bcopy if it handles overlap. */ + +/* Like bcopy except never gets confused by overlap. */ + +void +__malloc_safe_bcopy (afrom, ato, size) + __ptr_t afrom; + __ptr_t ato; + __malloc_size_t size; +{ + char *from = afrom, *to = ato; + + if (size <= 0 || from == to) + return; + + /* If the source and destination don't overlap, then bcopy can + handle it. If they do overlap, but the destination is lower in + memory than the source, we'll assume bcopy can handle that. */ + if (to < from || from + size <= to) + bcopy (from, to, size); + + /* Otherwise, we'll copy from the end. */ + else + { + register char *endf = from + size; + register char *endt = to + size; + + /* If TO - FROM is large, then we should break the copy into + nonoverlapping chunks of TO - FROM bytes each. However, if + TO - FROM is small, then the bcopy function call overhead + makes this not worth it. The crossover point could be about + anywhere. Since I don't think the obvious copy loop is too + bad, I'm trying to err in its favor. */ + if (to - from < 64) + { + do + *--endt = *--endf; + while (endf != from); + } + else + { + for (;;) + { + endt -= (to - from); + endf -= (to - from); + + if (endt < to) + break; + + bcopy (endf, endt, to - from); + } + + /* If SIZE wasn't a multiple of TO - FROM, there will be a + little left over. The amount left over is + (endt + (to - from)) - to, which is endt - from. */ + bcopy (from, to, endt - from); + } + } +} +#endif /* emacs */ + +#ifndef memmove +extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t)); +#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size)) +#endif + +#endif + + +#define min(A, B) ((A) < (B) ? (A) : (B)) + +/* Debugging hook for realloc. */ +__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size)); + +/* Resize the given region to the new size, returning a pointer + to the (possibly moved) region. This is optimized for speed; + some benchmarks seem to indicate that greater compactness is + achieved by unconditionally allocating and copying to a + new region. This module has incestuous knowledge of the + internals of both free and malloc. */ +__ptr_t +_realloc_internal (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + __ptr_t result; + int type; + __malloc_size_t block, blocks, oldlimit; + + if (size == 0) + { + _free_internal (ptr); + return _malloc_internal (0); + } + else if (ptr == NULL) + return _malloc_internal (size); + + block = BLOCK (ptr); + + type = _heapinfo[block].busy.type; + switch (type) + { + case 0: + /* Maybe reallocate a large block to a small fragment. */ + if (size <= BLOCKSIZE / 2) + { + result = _malloc_internal (size); + if (result != NULL) + { + memcpy (result, ptr, size); + _free_internal (ptr); + return result; + } + } + + /* The new size is a large allocation as well; + see if we can hold it in place. */ + blocks = BLOCKIFY (size); + if (blocks < _heapinfo[block].busy.info.size) + { + /* The new size is smaller; return + excess memory to the free list. */ + _heapinfo[block + blocks].busy.type = 0; + _heapinfo[block + blocks].busy.info.size + = _heapinfo[block].busy.info.size - blocks; + _heapinfo[block].busy.info.size = blocks; + /* We have just created a new chunk by splitting a chunk in two. + Now we will free this chunk; increment the statistics counter + so it doesn't become wrong when _free_internal decrements it. */ + ++_chunks_used; + _free_internal (ADDRESS (block + blocks)); + result = ptr; + } + else if (blocks == _heapinfo[block].busy.info.size) + /* No size change necessary. */ + result = ptr; + else + { + /* Won't fit, so allocate a new region that will. + Free the old region first in case there is sufficient + adjacent free space to grow without moving. */ + blocks = _heapinfo[block].busy.info.size; + /* Prevent free from actually returning memory to the system. */ + oldlimit = _heaplimit; + _heaplimit = 0; + _free_internal (ptr); + result = _malloc_internal (size); + if (_heaplimit == 0) + _heaplimit = oldlimit; + if (result == NULL) + { + /* Now we're really in trouble. We have to unfree + the thing we just freed. Unfortunately it might + have been coalesced with its neighbors. */ + if (_heapindex == block) + (void) _malloc_internal (blocks * BLOCKSIZE); + else + { + __ptr_t previous + = _malloc_internal ((block - _heapindex) * BLOCKSIZE); + (void) _malloc_internal (blocks * BLOCKSIZE); + _free_internal (previous); + } + return NULL; + } + if (ptr != result) + memmove (result, ptr, blocks * BLOCKSIZE); + } + break; + + default: + /* Old size is a fragment; type is logarithm + to base two of the fragment size. */ + if (size > (__malloc_size_t) (1 << (type - 1)) && + size <= (__malloc_size_t) (1 << type)) + /* The new size is the same kind of fragment. */ + result = ptr; + else + { + /* The new size is different; allocate a new space, + and copy the lesser of the new size and the old. */ + result = _malloc_internal (size); + if (result == NULL) + return NULL; + memcpy (result, ptr, min (size, (__malloc_size_t) 1 << type)); + _free_internal (ptr); + } + break; + } + + return result; +} + +__ptr_t +realloc (ptr, size) + __ptr_t ptr; + __malloc_size_t size; +{ + if (!__malloc_initialized && !__malloc_initialize ()) + return NULL; + + return (__realloc_hook != NULL ? *__realloc_hook : _realloc_internal) + (ptr, size); +} +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + +/* Allocate an array of NMEMB elements each SIZE bytes long. + The entire array is initialized to zeros. */ +__ptr_t +calloc (nmemb, size) + register __malloc_size_t nmemb; + register __malloc_size_t size; +{ + register __ptr_t result = malloc (nmemb * size); + + if (result != NULL) + (void) memset (result, 0, nmemb * size); + + return result; +} +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with the GNU C Library; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + +#ifndef __GNU_LIBRARY__ +#define __sbrk sbrk +#endif + +#ifdef __GNU_LIBRARY__ +/* It is best not to declare this and cast its result on foreign operating + systems with potentially hostile include files. */ + +#include <stddef.h> +extern __ptr_t __sbrk __P ((ptrdiff_t increment)); +#endif + +#ifndef NULL +#define NULL 0 +#endif + +/* Allocate INCREMENT more bytes of data space, + and return the start of data space, or NULL on errors. + If INCREMENT is negative, shrink data space. */ +__ptr_t +__default_morecore (increment) + __malloc_ptrdiff_t increment; +{ + __ptr_t result = (__ptr_t) __sbrk (increment); + if (result == (__ptr_t) -1) + return NULL; + return result; +} +/* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. */ + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + +#if __DJGPP__ - 0 == 1 + +/* There is some problem with memalign in DJGPP v1 and we are supposed + to omit it. Noone told me why, they just told me to do it. */ + +#else + +__ptr_t (*__memalign_hook) __P ((size_t __size, size_t __alignment)); + +__ptr_t +memalign (alignment, size) + __malloc_size_t alignment; + __malloc_size_t size; +{ + __ptr_t result; + unsigned long int adj, lastadj; + + if (__memalign_hook) + return (*__memalign_hook) (alignment, size); + + /* Allocate a block with enough extra space to pad the block with up to + (ALIGNMENT - 1) bytes if necessary. */ + result = malloc (size + alignment - 1); + if (result == NULL) + return NULL; + + /* Figure out how much we will need to pad this particular block + to achieve the required alignment. */ + adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment; + + do + { + /* Reallocate the block with only as much excess as it needs. */ + free (result); + result = malloc (adj + size); + if (result == NULL) /* Impossible unless interrupted. */ + return NULL; + + lastadj = adj; + adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment; + /* It's conceivable we might have been so unlucky as to get a + different block with weaker alignment. If so, this block is too + short to contain SIZE after alignment correction. So we must + try again and get another block, slightly larger. */ + } while (adj > lastadj); + + if (adj != 0) + { + /* Record this block in the list of aligned blocks, so that `free' + can identify the pointer it is passed, which will be in the middle + of an allocated block. */ + + struct alignlist *l; + for (l = _aligned_blocks; l != NULL; l = l->next) + if (l->aligned == NULL) + /* This slot is free. Use it. */ + break; + if (l == NULL) + { + l = (struct alignlist *) malloc (sizeof (struct alignlist)); + if (l == NULL) + { + free (result); + return NULL; + } + l->next = _aligned_blocks; + _aligned_blocks = l; + } + l->exact = result; + result = l->aligned = (char *) result + alignment - adj; + } + + return result; +} + +#endif /* Not DJGPP v1 */ +/* Allocate memory on a page boundary. + Copyright (C) 1991, 92, 93, 94, 96 Free Software Foundation, Inc. + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with this library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 675 Mass Ave, +Cambridge, MA 02139, USA. + + The author may be reached (Email) at the address mike@ai.mit.edu, + or (US mail) as Mike Haertel c/o Free Software Foundation. */ + +#if defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC) + +/* Emacs defines GMALLOC_INHIBIT_VALLOC to avoid this definition + on MSDOS, where it conflicts with a system header file. */ + +#define ELIDE_VALLOC + +#endif + +#ifndef ELIDE_VALLOC + +#if defined (__GNU_LIBRARY__) || defined (_LIBC) +#include <stddef.h> +#include <sys/cdefs.h> +extern size_t __getpagesize __P ((void)); +#else +#include "getpagesize.h" +#define __getpagesize() getpagesize() +#endif + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include <malloc.h> +#endif + +static __malloc_size_t pagesize; + +__ptr_t +valloc (size) + __malloc_size_t size; +{ + if (pagesize == 0) + pagesize = __getpagesize (); + + return memalign (pagesize, size); +} + +#endif /* Not ELIDE_VALLOC. */ @@ -0,0 +1,138 @@ +/* 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. + */ + +/* "gsubr.c" CCLOs taking general number of required, optional, and rest args. + Author: Radey Shouman */ + +#include "scm.h" + +#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) (VELTS(cclo)[1]) +#define GSUBR_PROC(cclo) (VELTS(cclo)[2]) + +static SCM f_gsubr_apply; +SCM make_gsubr(name, req, opt, rst, fcn) + char *name; + int req, opt, rst; + SCM (*fcn)(); +{ + switch GSUBR_MAKTYPE(req, opt, rst) { + case GSUBR_MAKTYPE(0, 0, 0): return make_subr(name, tc7_subr_0, fcn); + case GSUBR_MAKTYPE(1, 0, 0): return make_subr(name, tc7_subr_1, fcn); + case GSUBR_MAKTYPE(0, 1, 0): return make_subr(name, tc7_subr_1o, fcn); + case GSUBR_MAKTYPE(1, 1, 0): return make_subr(name, tc7_subr_2o, fcn); + case GSUBR_MAKTYPE(2, 0, 0): return make_subr(name, tc7_subr_2, fcn); + case GSUBR_MAKTYPE(3, 0, 0): return make_subr(name, tc7_subr_3, fcn); + case GSUBR_MAKTYPE(0, 0, 1): return make_subr(name, tc7_lsubr, fcn); + case GSUBR_MAKTYPE(2, 0, 1): return make_subr(name, tc7_lsubr_2, fcn); + default: + { + SCM symcell = sysintern(name, UNDEFINED); + SCM z, cclo = makcclo(f_gsubr_apply, 3L); + long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); + ASSERT(GSUBR_MAX >= req + opt + rst, MAKINUM(req + opt + rst), + OUTOFRANGE, "make_gsubr"); + if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) + tmp = 0; + NEWCELL(z); + SUBRF(z) = fcn; + CAR(z) = tmp + tc7_subr_0; + GSUBR_PROC(cclo) = z; + GSUBR_TYPE(cclo) = MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); + CDR(symcell) = cclo; + return cclo; + } + } +} + +char s_gsubr_apply[] = " gsubr-apply"; +SCM gsubr_apply(args) + SCM args; +{ + SCM self = CAR(args); + SCM (*fcn)() = SUBRF(GSUBR_PROC(self)); + int typ = INUM(GSUBR_TYPE(self)); + int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ); + SCM v[10]; + if (n > 10) wta(self, "internal programming error", s_gsubr_apply); + args = CDR(args); + for (i = 0; i < GSUBR_REQ(typ); i++) { +#ifndef RECKLESS + if IMP(args) + wnargs: wta(UNDEFINED, (char *)WNA, CHARS(SNAME(GSUBR_PROC(self)))); +#endif + v[i] = CAR(args); + args = CDR(args); + } + for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) { + if NIMP(args) { + v[i] = CAR(args); + args = CDR(args); + } + else + v[i] = UNDEFINED; + } + if GSUBR_REST(typ) + v[i] = args; + else + ASRTGO(NULLP(args), wnargs); + switch (n) { + 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]); + } +} + +void init_gsubr() +{ + f_gsubr_apply = make_subr(s_gsubr_apply, tc7_lsubr, gsubr_apply); +} diff --git a/install-sh b/install-sh new file mode 100644 index 0000000..89fc9b0 --- /dev/null +++ b/install-sh @@ -0,0 +1,238 @@ +#! /bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +tranformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 @@ -0,0 +1,703 @@ +/* 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. + */ + +/* "ioext.c" code for system calls in common between PC compilers and unix. + Author: Aubrey Jaffer */ + +#include "scm.h" + +#ifdef __EMX__ +# include <sys/types.h> +#endif + +#ifndef THINK_C +# ifdef vms +# include <stat.h> +# else +# include <sys/stat.h> +# endif +# ifdef __TURBOC__ +# include <io.h> +# endif +SCM stat2scm P((struct stat *stat_temp)); +/* int mkdir P((const char *path, mode_t mode)); */ +#endif +#ifdef hpux +# include <unistd.h> +#endif +#ifdef __sgi__ +# include <unistd.h> +#endif + +#ifndef STDC_HEADERS + int chdir P((const char *path)); + int unlink P((const char *name)); + int link P((const char *from, const char *to)); + char *getcwd P((char *buf, sizet size)); + int access P((const char *name, int type)); + int dup P((int fd)); + int dup2 P((int fd, int fd2)); + int close P((int fd)); + int rmdir P((const char *path)); + int execv P((const char *, char *const *)); + int execvp P((const char *, char *const *)); + int putenv P((const char *)); +#else +# ifdef _WIN32 +# include <direct.h> +# include <io.h> +# include <process.h> +# endif +# ifdef __HIGHC__ +# include <direct.h> +# include <dirent.h> +# include <process.h> +# define mkdir(foo,bar) mkdir(foo) +# endif +#endif /* STDC_HEADERS */ + +#ifdef __EMX__ + int execv P((const char *, char *const *)); + int execvp P((const char *, char *const *)); + int putenv P((const char *)); +#endif + +static char s_read_line[] = "read-line"; +SCM read_line(port) + SCM port; +{ + register int c; + register int j = 0; + sizet len = 30; + SCM tok_buf = makstr((long) len); + register char *p = CHARS(tok_buf); + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line); + if (EOF==(c = lgetc(port))) return EOF_VAL; + while(1) { + switch (c) { + case LINE_INCREMENTORS: + case EOF: + if (len==j) return tok_buf; + return resizuve(tok_buf, (SCM)MAKINUM(j)); + default: + if (j >= len) { + p = grow_tok_buf(tok_buf); + len = LENGTH(tok_buf); + } + p[j++] = c; + c = lgetc(port); + } + } +} +static char s_read_line1[] = "read-line!"; +SCM read_line1(str, port) + SCM str, port; +{ + register int c; + register int j = 0; + register char *p; + sizet len; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1); + p = CHARS(str); + len = LENGTH(str); + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + while(1) { + switch (c) { + case LINE_INCREMENTORS: + case EOF: + return MAKINUM(j); + default: + if (j >= len) { + lungetc(c, port); + return BOOL_F; + } + p[j++] = c; + c = lgetc(port); + } + } +} +static char s_write_line[] = "write-line"; +SCM l_write_line(obj, port) + SCM obj, port; +{ + display(obj, port); + return newline(port); +} + +static char s_file_position[] = "file-position", + s_file_set_pos[] = "file-set-position"; +SCM file_position(port) + SCM port; +{ + long ans; + ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position); + SYSCALL(ans = ftell(STREAM(port));); + if CRDYP(port) ans--; + return MAKINUM(ans); + } +SCM file_set_position(port, pos) + SCM port, pos; +{ + SCM ans; + ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos); + CLRDY(port); /* Clear ungetted char */ + SYSCALL(ans = (fseek(STREAM(port), INUM(pos), 0)) ? BOOL_F : BOOL_T;); +#ifdef HAVE_PIPE +# ifdef ESPIPE + if (!OPIOPORTP(port)) + ASSERT(ESPIPE != errno, port, ARG1, s_file_set_pos); +# endif +#endif + return ans; +} + +static char s_reopen_file[] = "reopen-file"; +SCM reopen_file(filename, modes, port) + SCM filename, modes, port; +{ + FILE *f; + ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file); + ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_reopen_file); + DEFER_INTS; + ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file); + SYSCALL(f = freopen(CHARS(filename), CHARS(modes), STREAM(port));); + if (!f) port = BOOL_F; + else { + SETSTREAM(port, f); + if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes)))) + i_setbuf0(port); + } + ALLOW_INTS; + return port; +} + +#ifndef MCH_AMIGA + +static char s_dup[]="duplicate-port"; +SCM l_dup(oldpt, modes) + SCM oldpt, modes; +{ + int tfd; + FILE *f; + SCM newpt; + ASSERT(NIMP(oldpt) && OPPORTP(oldpt), oldpt, ARG1, s_dup); + ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_dup); + NEWCELL(newpt); + DEFER_INTS; + SYSCALL(tfd = dup(fileno(STREAM(oldpt)));); + if (-1==tfd) {ALLOW_INTS;return BOOL_F;}; + SYSCALL(f = fdopen(tfd, CHARS(modes));); + if (!f) { + close(tfd); + wta(MAKINUM(tfd), (char *)NALLOC, s_port_type); + } + SETSTREAM(newpt, f); + if (BUF0 & (CAR(newpt) = tc16_fport | mode_bits(CHARS(modes)))) + i_setbuf0(newpt); + ALLOW_INTS; + return newpt; +} +static char s_dup2[]="redirect-port!"; +SCM l_dup2(into_pt, from_pt) + SCM into_pt, from_pt; +{ + int ans, oldfd, newfd; + DEFER_INTS; + ASSERT(NIMP(into_pt) && OPPORTP(into_pt), into_pt, ARG1, s_dup2); + ASSERT(NIMP(from_pt) && OPPORTP(from_pt), from_pt, ARG1, s_dup2); + oldfd = fileno(STREAM(into_pt)); + newfd = fileno(STREAM(from_pt)); + SYSCALL(ans = dup2(oldfd, newfd);); + if (-1==ans) {ALLOW_INTS;return BOOL_F;}; + ALLOW_INTS; + return into_pt; +} + +# ifndef vms +# ifndef _WIN32 +# include <dirent.h> +static char s_opendir[]="opendir"; +SCM l_opendir(dirname) + SCM dirname; +{ + DIR *ds; + SCM dir; + ASSERT(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir); + NEWCELL(dir); + DEFER_INTS; + SYSCALL(ds = opendir(CHARS(dirname));); + if (!ds) {ALLOW_INTS; return BOOL_F;} + CAR(dir) = tc16_dir | OPN; + SETCDR(dir, ds); + ALLOW_INTS; + return dir; +} +static char s_readdir[]="readdir"; +SCM l_readdir(port) + SCM port; +{ + struct dirent *rdent; + DEFER_INTS; + ASSERT(OPDIRP(port), port, ARG1, s_readdir); + SYSCALL(rdent = readdir((DIR *)CDR(port));); + if (!rdent) {ALLOW_INTS; return BOOL_F;} + ALLOW_INTS; + /* rdent could be overwritten by another readdir to the same handle */ + return makfrom0str(rdent->d_name); +} +static char s_rewinddir[]="rewinddir"; +SCM l_rewinddir(port) + SCM port; +{ + ASSERT(OPDIRP(port), port, ARG1, s_rewinddir); + rewinddir((DIR *)CDR(port)); + return UNSPECIFIED; +} +static char s_closedir[]="closedir"; +SCM l_closedir(port) + SCM port; +{ + int sts; + ASSERT(DIRP(port), port, ARG1, s_closedir); + DEFER_INTS; + if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;} + SYSCALL(sts = closedir((DIR *)CDR(port));); + if (sts) {ALLOW_INTS; return BOOL_F;} + CAR(port) = tc16_dir; + ALLOW_INTS; + return BOOL_T; +} + +int dir_print(sexp, port, writing) + SCM sexp; SCM port; int writing; +{ + prinport(sexp, port, "directory"); + return !0; +} +sizet dir_free(p) + CELLPTR p; +{ + if OPENP((SCM)p) closedir((DIR *)CDR((SCM)p)); + return 0; +} + +long tc16_dir; +static smobfuns dir_smob = {mark0, dir_free, dir_print, 0}; +# endif /* _WIN32 */ +# endif /* vms */ + +static char s_mkdir[] = "mkdir"; +SCM l_mkdir(path, mode) + SCM path, mode; +{ + int val; + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir); + ASSERT(INUMP(mode), mode, ARG2, s_mkdir); +# ifdef _WIN32 + SYSCALL(val = mkdir(CHARS(path));); +# else + SYSCALL(val = mkdir(CHARS(path), INUM(mode));); + /* (mode_t)INUM(mode) might be needed */ +# endif + return val ? BOOL_F : BOOL_T; +} +# ifdef vms +static char s_dot_dir[] = ".DIR"; +# endif +static char s_rmdir[] = "rmdir"; +SCM l_rmdir(path) + SCM path; +{ + int val; + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir); +# ifdef vms + return del_fil(st_append(cons2(path, s_dot_dir, EOL))); +# else + SYSCALL(val = rmdir(CHARS(path));); + return val ? BOOL_F : BOOL_T; +# endif +} +#endif /* MCH_AMIGA */ + +#ifndef THINK_C +static char s_chdir[] = "chdir"; +SCM lchdir(str) + SCM str; +{ + int ans; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_chdir); + SYSCALL(ans = chdir(CHARS(str));); + return ans ? BOOL_F : BOOL_T; +} +# ifndef MCH_AMIGA +# ifdef __TURBOC__ +# include <dir.h> +# endif +SCM l_getcwd() +{ + char *ans; +# ifndef vms + char wd[256]; + SYSCALL(ans = getcwd(wd, 256);); + return ans ? makfrom0str(wd) : BOOL_F; +# else + SYSCALL(ans = getenv("PATH");); + return ans ? makfrom0str(ans) : BOOL_F; +# endif +} + +static char s_chmod[] = "chmod"; +SCM l_chmod(pathname, mode) + SCM pathname, mode; +{ + int val; + ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod); + ASSERT(INUMP(mode), mode, ARG2, s_chmod); + SYSCALL(val = chmod(CHARS(pathname), INUM(mode));); + return val ? BOOL_F : BOOL_T; +} + +# ifndef vms +# ifdef __EMX__ +# include <sys/utime.h> +# else +# ifdef _WIN32 +# include <sys/utime.h> +# else +# include <utime.h> +# endif +# endif +static char s_utime[] = "utime"; +SCM l_utime(pathname, acctime, modtime) + SCM pathname, acctime, modtime; +{ + int val; + struct utimbuf utm_tmp; + utm_tmp.actime = num2ulong(acctime, (char *)ARG2, s_utime); + utm_tmp.modtime = num2ulong(modtime, (char *)ARG3, s_utime); + ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime); + SYSCALL(val = utime(CHARS(pathname), &utm_tmp);); + return val ? BOOL_F : BOOL_T; +} +# endif /* vms */ + +static char s_umask[] = "umask"; +SCM l_umask(mode) + SCM mode; +{ + ASSERT(INUMP(mode), mode, ARG1, s_umask); + return MAKINUM(umask(INUM(mode))); +} +# endif /* MCH_AMIGA */ +#endif /* THINK_C */ + +static char s_ren_fil[] = "rename-file"; +SCM ren_fil(oldname, newname) + SCM oldname, newname; +{ + SCM ans; + ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil); + ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil); +#ifdef STDC_HEADERS + SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;); + return ans; +#else + DEFER_INTS; + SYSCALL(ans = link(CHARS(oldname), CHARS(newname)) ? BOOL_F : BOOL_T;); + if (!FALSEP(ans)) { + SYSCALL(ans = unlink(CHARS(oldname)) ? BOOL_F : BOOL_T;); + if FALSEP(ans) + SYSCALL(unlink(CHARS(newname));); /* unlink failed. remove new name */ + } + ALLOW_INTS; + return ans; +#endif +} +static char s_fileno[] = "fileno"; +SCM l_fileno(port) + SCM port; +{ + ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno); + if (tc16_fport != TYP16(port)) return BOOL_F; + return MAKINUM(fileno(STREAM(port))); +} +static char s_isatty[] = "isatty?"; +SCM l_isatty(port) + SCM port; +{ + ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty); + if (tc16_fport != TYP16(port)) return BOOL_F; + return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F; +} +#ifndef F_OK +# define F_OK 00 +# define X_OK 01 +# define W_OK 02 +# define R_OK 04 +#endif +static char s_access[] = "access"; +SCM l_access(pathname, mode) + SCM pathname, mode; +{ + int val; + int imodes; + ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access); + if INUMP(mode) imodes = INUM(mode); + else { + ASSERT(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access); + imodes = F_OK | (strchr(CHARS(mode), 'r') ? R_OK : 0) + | (strchr(CHARS(mode), 'w') ? W_OK : 0) + | (strchr(CHARS(mode), 'x') ? X_OK : 0); + } + SYSCALL(val = access(CHARS(pathname), imodes);); + return val ? BOOL_F : BOOL_T; +} + +#ifndef THINK_C + +char s_stat[] = "stat"; +SCM l_stat(str) + SCM str; +{ + int i; + struct stat stat_temp; + if IMP(str) + badarg1: wta(str, (char *)ARG1, s_stat); + if STRINGP(str) {SYSCALL(i = stat(CHARS(str), &stat_temp););} + else { +# ifndef MCH_AMIGA + if (!OPFPORTP(str)) goto badarg1; + SYSCALL(i = fstat(fileno(STREAM(str)), &stat_temp);); +# else + goto badarg1; +# endif + } + if (i) return BOOL_F; + return stat2scm(&stat_temp); +} +# ifdef MCH_AMIGA +SCM stat2scm(stat_temp) + struct stat *stat_temp; +{ + SCM ans = make_vector(MAKINUM(3), UNSPECIFIED); + SCM *ve = VELTS(ans); + ve[ 0] = ulong2num((unsigned long)stat_temp->st_attr); + ve[ 1] = ulong2num((unsigned long)stat_temp->st_mtime); + ve[ 2] = ulong2num((unsigned long)stat_temp->st_size); + return ans; +} +# else +SCM stat2scm(stat_temp) + struct stat *stat_temp; +{ + SCM ans = make_vector(MAKINUM(11), UNSPECIFIED); + SCM *ve = VELTS(ans); + ve[ 0] = ulong2num((unsigned long)stat_temp->st_dev); + ve[ 1] = ulong2num((unsigned long)stat_temp->st_ino); + ve[ 2] = ulong2num((unsigned long)stat_temp->st_mode); + ve[ 3] = ulong2num((unsigned long)stat_temp->st_nlink); + ve[ 4] = ulong2num((unsigned long)stat_temp->st_uid); + ve[ 5] = ulong2num((unsigned long)stat_temp->st_gid); + ve[ 6] = ulong2num((unsigned long)stat_temp->st_rdev); + ve[ 7] = ulong2num((unsigned long)stat_temp->st_size); + ve[ 8] = ulong2num((unsigned long)stat_temp->st_atime); + ve[ 9] = ulong2num((unsigned long)stat_temp->st_mtime); + ve[10] = ulong2num((unsigned long)stat_temp->st_ctime); + return ans; +} +# ifdef __TURBOC__ +# include <process.h> +# endif +SCM l_getpid() +{ + return MAKINUM((unsigned long)getpid()); +} +# endif /* MCH_AMIGA */ +#endif /* THINK_C */ + +#ifndef __IBMC__ +# ifndef THINK_C +# ifndef __WATCOMC__ +# ifndef GO32 +# ifndef _Windows +# ifdef __TURBOC__ +# include <process.h> +# endif +char s_execv[] = "execv"; +char s_execvp[] = "execvp"; +SCM i_execv(modes, path, args) + char * modes; + SCM path, args; +{ + char **execargv; + int i = ilength(args); + ASSERT(i>0, args, WNA, s_execv); + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_execv); + /* dowinds(EOL, ilength(dynwinds)); */ + args = cons(path, args); + DEFER_INTS; + execargv = makargvfrmstrs(args, s_execv); + ALLOW_INTS; + (strchr(modes, 'p') ? execvp : execv)(execargv[0], &execargv[1]); + perror(execargv[0]); + return MAKINUM(errno); +} +SCM lexec(path, arg0, args) + SCM path, arg0, args; +{ + return i_execv("", path, cons(arg0, args)); +} +SCM lexecp(path, arg0, args) + SCM path, arg0, args; +{ + return i_execv("p", path, cons(arg0, args)); +} +SCM lexecv(path, args) + SCM path, args; +{ + return i_execv("", path, args); +} +SCM lexecvp(path, args) + SCM path, args; +{ + return i_execv("p", path, args); +} +static char s_putenv[] = "putenv"; +SCM l_putenv(str) + SCM str; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_putenv); + return putenv(CHARS(str)) ? BOOL_F : BOOL_T; +} +# endif +# endif +# endif +# endif +#endif + +static iproc subr1s[] = { + {s_file_position, file_position}, + {s_fileno, l_fileno}, + {s_isatty, l_isatty}, +#ifndef MCH_AMIGA +# ifndef vms +# ifndef _WIN32 + {s_opendir, l_opendir}, + {s_readdir, l_readdir}, + {s_rewinddir, l_rewinddir}, + {s_closedir, l_closedir}, +# endif +# endif + {s_rmdir, l_rmdir}, +#endif +#ifndef THINK_C +# ifndef MCH_AMIGA + {s_umask, l_umask}, +# endif + {s_chdir, lchdir}, + {s_stat, l_stat}, +#endif + {0, 0}}; + +static iproc subr1os[] = { + {s_read_line, read_line}, + {0, 0}}; + +static iproc subr2s[] = { + {s_ren_fil, ren_fil}, + {s_access, l_access}, +#ifndef MCH_AMIGA + {s_dup, l_dup}, + {s_dup2, l_dup2}, + {s_mkdir, l_mkdir}, +# ifndef THINK_C + {s_chmod, l_chmod}, +# endif +#endif + {0, 0}}; + +static iproc subr2os[] = { + {s_file_set_pos, file_set_position}, + {s_read_line1, read_line1}, + {s_write_line, l_write_line}, + {0, 0}}; + +void init_ioext() +{ + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(subr2s, tc7_subr_2); + make_subr(s_reopen_file, tc7_subr_3, reopen_file); +#ifndef THINK_C +# ifndef MCH_AMIGA + make_subr("getpid", tc7_subr_0, l_getpid); + make_subr("getcwd", tc7_subr_0, l_getcwd); +# ifndef vms +# ifndef _WIN32 + make_subr(s_utime, tc7_subr_3, l_utime); + tc16_dir = newsmob(&dir_smob); +# endif +# endif +# endif +#endif +#ifndef __IBMC__ +# ifndef THINK_C +# ifndef __WATCOMC__ +# ifndef GO32 +# ifndef _Windows + make_subr(s_execv, tc7_subr_2, lexecv); + make_subr(s_execvp, tc7_subr_2, lexecvp); + make_subr("execl", tc7_lsubr_2, lexec); + make_subr("execlp", tc7_lsubr_2, lexecp); + make_subr(s_putenv, tc7_subr_1, l_putenv); +# endif +# endif +# endif +# endif +#endif + add_feature("i/o-extensions"); + add_feature("line-i/o"); +} diff --git a/mkinstalldirs b/mkinstalldirs new file mode 100755 index 0000000..0e29377 --- /dev/null +++ b/mkinstalldirs @@ -0,0 +1,35 @@ +#!/bin/sh +# Make directory hierarchy. +# Written by Noah Friedman <friedman@prep.ai.mit.edu> +# Public domain. + +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +errstatus=0 + +for file in ${1+"$@"} ; do + oIFS="${IFS}" + # Some sh's can't handle IFS=/ for some reason. + IFS='%' + set - `echo ${file} | sed -e 's@/@%@g' -e 's@^%@/@'` + IFS="${oIFS}" + + pathcomp='' + + for d in ${1+"$@"} ; do + pathcomp="${pathcomp}${d}" + + if test ! -d "${pathcomp}"; then + echo "mkdir $pathcomp" 1>&2 + mkdir "${pathcomp}" || errstatus=$? + fi + + pathcomp="${pathcomp}/" + done +done + +exit $errstatus + +# eof diff --git a/patchlvl.h b/patchlvl.h new file mode 100644 index 0000000..97543ec --- /dev/null +++ b/patchlvl.h @@ -0,0 +1,8 @@ +/* SCMVERSION is a string for the version specifier. The leading + number is the major version number, the letter is the revision ("a" + for alpha release, "b" for beta release, "c", and so on), and the + trailing number is the patchlevel. */ + +#ifndef SCMVERSION +# define SCMVERSION "4e6" +#endif @@ -0,0 +1,78 @@ +/* Copyright (C) 1991 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. + */ + +/* "pi.c", program for computing digits of numerical value of PI. + Author: Aubrey Jaffer + +pi <n> <d> prints out <n> digits of pi in groups of <d> digits. + +'Spigot' algorithm origionally due to Stanly Rabinowitz. +This algorithm takes time proportional to the square of <n>/<d>. +This fact can make comparisons of computational speed between systems +of vastly differring performances quicker and more accurate. + +Try: pi 100 5 +The digit size <d> will have to be reduced for larger <n> or an +error due to overflow will occur. */ + +short *calloc(); +main(c,v) +int c;char **v;{ + int n=200,j=0,m,b=2,k=0,t,r=1,d=5; + long q; + short *a; + if(c>1)n=atoi(v[1]); + if(c>2)d=atoi(v[2]); + while(k++<d)r=r*10; + n=n/d+1; + k=m=3.322*n*d; + a=calloc(1+m,2); + while(k)a[--k]=2; + for(a[m]=4;j<n;b=q%r){ + q=0; + for(k=m;k;){ + q+=a[k]*r; + t=(2*k+1); + a[k]=q%t; + q=q/t; + q*=k--;} + printf("%0*d%s",d,b+q/r,++j%10?" ":"\n");} + puts("");} @@ -0,0 +1,165 @@ +;; Copyright (C) 1991, 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. + +;;;; "pi.scm", program for computing digits of numerical value of PI. +;;;; "bigpi.scm", program for computing digits of numerical value of PI. +;;;; "e.scm", program for computing digits of numerical value of 'e'. +;;; Authors: Aubrey Jaffer & Jerry D. Hedden + +;;; (pi <n> <d>) prints out <n> digits of pi in groups of <d> digits. + +;;; 'Spigot' algorithm origionally due to Stanly Rabinowitz. +;;; This algorithm takes time proportional to the square of <n>/<d>. +;;; This fact can make comparisons of computational speed between systems +;;; of vastly differring performances quicker and more accurate. + +;;; Try (pi 100 5) +;;; The digit size <d> will have to be reduced for larger <n> or an +;;; overflow error will occur (on systems lacking bignums). + +;;; It your Scheme has bignums try (pi 1000). + +(define (pi n . args) + (if (null? args) (bigpi n) + (let* ((d (car args)) + (r (do ((s 1 (* 10 s)) + (i d (- i 1))) + ((zero? i) s))) + (n (+ (quotient n d) 1)) + (m (quotient (* n d 3322) 1000)) + (a (make-vector (+ 1 m) 2))) + (vector-set! a m 4) + (do ((j 1 (+ 1 j)) + (q 0 0) + (b 2 (remainder q r))) + ((> j n)) + (do ((k m (- k 1))) + ((zero? k)) + (set! q (+ q (* (vector-ref a k) r))) + (let ((t (+ 1 (* 2 k)))) + (vector-set! a k (remainder q t)) + (set! q (* k (quotient q t))))) + (let ((s (number->string (+ b (quotient q r))))) + (do ((l (string-length s) (+ 1 l))) + ((>= l d) (display s)) + (display #\0))) + (if (zero? (modulo j 10)) (newline) (display #\ ))) + (newline)))) + +;;; (pi <n>) prints out <n> digits of pi. + +;;; 'Spigot' algorithm originally due to Stanly Rabinowitz: +;;; +;;; PI = 2+(1/3)*(2+(2/5)*(2+(3/7)*(2+ ... *(2+(k/(2k+1))*(4)) ... ))) +;;; +;;; where 'k' is approximately equal to the desired precision of 'n' +;;; places times 'log2(10)'. +;;; +;;; This version takes advantage of "bignums" in SCM to compute all +;;; of the requested digits in one pass! Basically, it calculates +;;; the truncated portion of (PI * 10^n), and then displays it in a +;;; nice format. + +(define (bigpi digits) + (let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10 + (z (inexact->exact (truncate ; z = number of terms + (/ (* n (log 10)) (log 2))))) + (q (do ((x 2 (* 10000000000 x)) ; q = 2 * 10^n + (i (/ n 10) (- i 1))) + ((zero? i) x))) + (_pi (number->string ; _pi = PI * 10^n + ;; do the calculations in one pass!!! + (let pi_calc ((j z) (k (+ z z 1)) (p (+ q q))) + (if (zero? j) + p + (pi_calc (- j 1) (- k 2) (+ q (quotient (* p j) k)))))))) + ;; print out the result ("3." followed by 5 groups of 10 digits per line) + (display (substring _pi 0 1)) (display #\.) (newline) + (do ((i 0 (+ i 10))) + ((>= i n)) + (display (substring _pi (+ i 1) (+ i 11))) + (display (if (zero? (modulo (+ i 10) 50)) #\newline #\ ))) + (if (not (zero? (modulo n 50))) (newline)))) + +;;; (e <n>) prints out <n> digits of 'e'. + +;;; Uses the formula: +;;; +;;; 1 1 1 1 1 +;;; e = 1 + -- + -- + -- + -- + ... + -- +;;; 1! 2! 3! 4! k! +;;; +;;; where 'k' is determined using the desired precision 'n' in: +;;; +;;; n < ((k * (ln(k) - 1)) / ln(10)) +;;; +;;; which uses Stirling's formula for approximating ln(k!) +;;; +;;; This program takes advantage of "bignums" in SCM to compute all +;;; the requested digits at once! Basically, it calculates the +;;; fractional part of 'e' (i.e., e-2) as a fraction of two bignums +;;; 'e_n' and 'e_d', determines the integer part of (e_n * 10^n)/e_d, +;;; and then displays it in a nice format. + +(define (e digits) + (let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10 + (k (do ((i 15 (+ i 1))) ; k = number of terms + ((< n (/ (* i (- (log i) 1)) (log 10))) i))) + (q (do ((x 1 (* 10000000000 x)) ; q = 10^n + (i (/ n 10) (- i 1))) + ((zero? i) x))) + (_e (let ((ee + ; do calculations + (let e_calc ((i k) (e_d 1) (e_n 0)) + (if (= i 1) + (cons (* q e_n) e_d) + (e_calc (- i 1) (* e_d i) (+ e_n e_d)))))) + (number->string (+ (quotient (car ee) (cdr ee)) + ; rounding + (if (< (remainder (car ee) (cdr ee)) + (quotient (cdr ee) 2)) + 0 1)))))) + ;; print out the result ("2." followed by 5 groups of 10 digits per line) + (display "2.") (newline) + (do ((i 0 (+ i 10))) + ((>= i n)) + (display (substring _e i (+ i 10))) + (display (if (zero? (modulo (+ i 10) 50)) #\newline #\ ))) + (if (not (zero? (modulo n 50))) (newline)))) @@ -0,0 +1,408 @@ +/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "posix.c" functions only in Posix (unix). + Author: Aubrey Jaffer */ + +#include "scm.h" + +#include <pwd.h> +#include <sys/types.h> +#include <sys/wait.h> + +#ifndef STDC_HEADERS + char *ttyname P((int fd)); + FILE *popen P((const char* command, const char* type)); + int pclose P((FILE* stream)); +#endif + + /* Only the superuser can successfully execute this call */ +static char s_chown[] = "chown"; +SCM l_chown(path, owner, group) + SCM path, owner, group; +{ + int val; + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_chown); + ASSERT(INUMP(owner), owner, ARG2, s_chown); + ASSERT(INUMP(group), group, ARG3, s_chown); + SYSCALL(val = chown(CHARS(path), INUM(owner), INUM(group));); + return val ? BOOL_F : BOOL_T; +} + +static char s_link[] = "link"; +SCM l_link(oldpath, newpath) + SCM oldpath, newpath; +{ + int val; + ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_link); + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_link); + SYSCALL(val = link(CHARS(oldpath), CHARS(newpath));); + return val ? BOOL_F : BOOL_T; +} + +SCM l_pipe() +{ + int fd[2], ret; + FILE *f_rd, *f_wt; + SCM p_rd, p_wt; + NEWCELL(p_rd); NEWCELL(p_wt); + SYSCALL(ret = pipe(fd);); + if (ret) {ALLOW_INTS; return BOOL_F;} + SYSCALL(f_rd = fdopen(fd[0], "r");); + if (!f_rd) { + close(fd[0]); + goto errout; + } + SYSCALL(f_wt = fdopen(fd[1], "w");); + if (!f_wt) { + fclose(f_rd); + errout: + close(fd[1]); + wta(UNDEFINED, (char *)NALLOC, s_port_type); + } + CAR(p_rd) = tc16_fport | mode_bits("r"); + CAR(p_wt) = tc16_fport | mode_bits("w"); + SETSTREAM(p_rd, f_rd); + SETSTREAM(p_wt, f_wt); + ALLOW_INTS; + return cons(p_rd, p_wt); +} + +char s_op_pipe[] = "open-pipe"; +SCM open_pipe(pipestr, modes) + SCM pipestr, modes; +{ + FILE *f; + register SCM z; + ASSERT(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe); + ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_op_pipe); + NEWCELL(z); + /* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/ + DEFER_INTS; + ignore_signals(); + SYSCALL(f = popen(CHARS(pipestr), CHARS(modes));); + unignore_signals(); + if (!f) z = BOOL_F; + else { + CAR(z) = tc16_pipe | OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG); + SETSTREAM(z, f); + } + ALLOW_INTS; + return z; +} +SCM l_open_input_pipe(pipestr) + SCM pipestr; +{ + return open_pipe(pipestr, makfromstr("r", (sizeof "r")-1)); +} +SCM l_open_output_pipe(pipestr) + SCM pipestr; +{ + return open_pipe(pipestr, makfromstr("w", (sizeof "w")-1)); +} +static int prinpipe(exp, port, writing) + SCM exp; SCM port; int writing; +{ + prinport(exp, port, s_pipe); + return !0; +} + +static char scm_s_getgroups[] = "getgroups"; +SCM scm_getgroups() +{ + SCM grps, ans; + int ngroups = getgroups(NULL, 0); + if (!ngroups) return BOOL_F; + NEWCELL(grps); + DEFER_INTS; + { + gid_t *groups = (gid_t *)must_malloc(ngroups * sizeof(gid_t), + scm_s_getgroups); + int val = getgroups(ngroups, groups); + if (val < 0) { + must_free(groups); + ALLOW_INTS; + return BOOL_F; + } + SETCHARS(grps, groups); /* set up grps as a GC protect */ + SETLENGTH(grps, 0L + ngroups * sizeof(gid_t), tc7_string); + ALLOW_INTS; + ans = make_vector(MAKINUM(ngroups), UNDEFINED); + while (--ngroups >= 0) VELTS(ans)[ngroups] = MAKINUM(groups[ngroups]); + SETCHARS(grps, groups); /* to make sure grps stays around. */ + return ans; + } +} + +/* These 2 routines are not protected against `entry' being reused + before access to that structure is completed */ + +static char s_pwinfo[] = "getpw"; +SCM l_pwinfo(user) + SCM user; +{ + SCM ans = make_vector(MAKINUM(7), UNSPECIFIED); + struct passwd *entry; + SCM *ve = VELTS(ans); + DEFER_INTS; + if UNBNDP(user) SYSCALL(entry = getpwent();); + else if INUMP(user) SYSCALL(entry = getpwuid(INUM(user));); + else { + ASSERT(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo); + SYSCALL(entry = getpwnam(CHARS(user));); + } + ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->pw_name); + ve[ 1] = makfrom0str(entry->pw_passwd); + ve[ 2] = ulong2num((unsigned long)entry->pw_uid); + ve[ 3] = ulong2num((unsigned long)entry->pw_gid); + ve[ 4] = makfrom0str(entry->pw_gecos); + ve[ 5] = makfrom0str(entry->pw_dir); + ve[ 6] = makfrom0str(entry->pw_shell); + return ans; +} +#include <grp.h> +static char s_grinfo[] = "getgr"; +SCM l_grinfo(name) + SCM name; +{ + SCM ans = make_vector(MAKINUM(4), UNSPECIFIED); + struct group *entry; + SCM *ve = VELTS(ans); + DEFER_INTS; + if UNBNDP(name) SYSCALL(entry = getgrent();); + else if INUMP(name) SYSCALL(entry = getgrgid(INUM(name));); + else { + ASSERT(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo); + SYSCALL(entry = getgrnam(CHARS(name));); + } + ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->gr_name); + ve[ 1] = makfrom0str(entry->gr_passwd); + ve[ 2] = ulong2num((unsigned long)entry->gr_gid); + ve[ 3] = makfromstrs(-1, entry->gr_mem); + return ans; +} +SCM l_setgr(arg) + SCM arg; +{ + if (UNBNDP(arg) || FALSEP(arg)) endgrent(); + else setgrent(); + return UNSPECIFIED; +} +SCM l_setpw(arg) + SCM arg; +{ + if (UNBNDP(arg) || FALSEP(arg)) endpwent(); + else setpwent(); + return UNSPECIFIED; +} + +static char s_kill[] = "kill"; +SCM l_kill(pid, sig) + SCM pid, sig; +{ + int i; + ASSERT(INUMP(pid), pid, ARG1, s_kill); + ASSERT(INUMP(sig), sig, ARG2, s_kill); + SYSCALL(i = kill((int)INUM(pid), (int)INUM(sig));); + return MAKINUM(0L+i); +} +static char s_waitpid[] = "waitpid"; +SCM l_waitpid(pid, options) + SCM pid, options; +{ + int i, status; + ASSERT(INUMP(pid), pid, ARG1, s_waitpid); + ASSERT(INUMP(options), options, ARG2, s_waitpid); + SYSCALL(i = waitpid(INUM(pid), &status, INUM(options));); + return i < 0 ? BOOL_F : MAKINUM(0L+status); +} + +SCM l_getppid() +{ + return MAKINUM(0L+getppid()); +} + +SCM l_getuid() +{ + return MAKINUM(0L+getuid()); +} +SCM l_getgid() +{ + return MAKINUM(0L+getgid()); +} +#ifndef LACK_E_IDs +SCM l_geteuid() +{ + return MAKINUM(0L+geteuid()); +} +SCM l_getegid() +{ + return MAKINUM(0L+getegid()); +} +#endif + +static char s_setuid[] = "setuid"; +SCM l_setuid(id) + SCM id; +{ + ASSERT(INUMP(id), id, ARG1, s_setuid); + return setuid(INUM(id)) ? BOOL_F : BOOL_T; +} +static char s_setgid[] = "setgid"; +SCM l_setgid(id) + SCM id; +{ + ASSERT(INUMP(id), id, ARG1, s_setgid); + return setgid(INUM(id)) ? BOOL_F : BOOL_T; +} + +#ifndef LACK_E_IDs +static char s_seteuid[] = "seteuid"; +SCM l_seteuid(id) + SCM id; +{ + ASSERT(INUMP(id), id, ARG1, s_seteuid); + return seteuid(INUM(id)) ? BOOL_F : BOOL_T; +} +static char s_setegid[] = "setegid"; +SCM l_setegid(id) + SCM id; +{ + ASSERT(INUMP(id), id, ARG1, s_setegid); + return setegid(INUM(id)) ? BOOL_F : BOOL_T; +} +#endif + +static char s_ttyname[] = "ttyname"; +SCM l_ttyname(port) + SCM port; +{ + char *ans; + ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_ttyname); + if (tc16_fport != TYP16(port)) return BOOL_F; + SYSCALL(ans = ttyname(fileno(STREAM(port)));); + /* ans could be overwritten by another call to ttyname */ + return ans ? makfrom0str(ans) : BOOL_F; +} + +SCM l_fork() +{ + long pid = 0L + fork(); + return -1L==pid ? BOOL_F : MAKINUM(pid); +} + +#include <sys/utsname.h> +SCM l_uname() +{ + struct utsname buf; + SCM ans = make_vector(MAKINUM(5), UNSPECIFIED); + SCM *ve = VELTS(ans); + if (uname(&buf)) return BOOL_F; + ve[ 0] = makfrom0str(buf.sysname); + ve[ 1] = makfrom0str(buf.nodename); + ve[ 2] = makfrom0str(buf.release); + ve[ 3] = makfrom0str(buf.version); + ve[ 4] = makfrom0str(buf.machine); + /* ve[ 5] = makfrom0str(buf.domainname); */ + return ans; +} + +static iproc subr0s[] = { + {"pipe", l_pipe}, + {scm_s_getgroups, scm_getgroups}, + {"getppid", l_getppid}, + {"getuid", l_getuid}, + {"getgid", l_getgid}, +#ifndef LACK_E_IDs + {"getegid", l_getegid}, + {"geteuid", l_geteuid}, +#endif + {"uname", l_uname}, + {"fork", l_fork}, + {0, 0}}; + +static iproc subr1os[] = { + {s_pwinfo, l_pwinfo}, + {s_grinfo, l_grinfo}, + {"setpwent", l_setpw}, + {"setgrent", l_setgr}, + {0, 0}}; + +static iproc subr1s[] = { + {"setuid", l_setuid}, + {"setgid", l_setgid}, +#ifndef LACK_E_IDs + {"setegid", l_setegid}, + {"seteuid", l_seteuid}, +#endif + {"open-input-pipe", l_open_input_pipe}, + {"open-output-pipe", l_open_output_pipe}, + {s_ttyname, l_ttyname}, + {0, 0}}; + +static iproc subr2s[] = { + {s_link, l_link}, + {s_kill, l_kill}, + {s_waitpid, l_waitpid}, + {s_op_pipe, open_pipe}, + {0, 0}}; + +static iproc subr3s[] = { + {s_chown, l_chown}, + {0, 0}}; + +void init_posix() +{ + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(subr3s, tc7_subr_3); + add_feature("posix"); + ptobs[0x0ff & (tc16_pipe>>8)].fclose = pclose; + ptobs[0x0ff & (tc16_pipe>>8)].free = pclose; + ptobs[0x0ff & (tc16_pipe>>8)].print = prinpipe; + add_feature(s_pipe); +} diff --git a/pre-crt0.c b/pre-crt0.c new file mode 100644 index 0000000..67fd31c --- /dev/null +++ b/pre-crt0.c @@ -0,0 +1,9 @@ +/* This file is loaded before crt0.o on machines where we do not + remap part of the data space into text space in unexec. + On these machines, there is no problem with standard crt0.o's + that make environ an initialized variable. However, we do + need to make sure the label data_start exists anyway. */ + +/* Create a label to appear at the beginning of data space. */ + +int data_start = 0; diff --git a/r4rstest.scm b/r4rstest.scm new file mode 100644 index 0000000..6573e20 --- /dev/null +++ b/r4rstest.scm @@ -0,0 +1,1038 @@ +;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation; either version 2, or (at your option) any +;; later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; To receive a copy of the GNU General Public License, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA; or view +;; http://www-swiss.ai.mit.edu/~jaffer/GPL.html + +;;;; "r4rstest.scm" Test correctness of scheme implementations. +;;; Author: Aubrey Jaffer + +;;; This includes examples from +;;; William Clinger and Jonathan Rees, editors. +;;; Revised^4 Report on the Algorithmic Language Scheme +;;; and the IEEE specification. + +;;; The input tests read this file expecting it to be named "r4rstest.scm". +;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running +;;; these tests. You may need to delete them in order to run +;;; "r4rstest.scm" more than once. + +;;; There are three optional tests: +;;; (TEST-CONT) tests multiple returns from call-with-current-continuation +;;; +;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE +;;; +;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by +;;; either standard. + +;;; If you are testing a R3RS version which does not have `list?' do: +;;; (define list? #f) + +;;; send corrections or additions to jaffer@ai.mit.edu + +(define cur-section '())(define errs '()) +(define SECTION (lambda args + (display "SECTION") (write args) (newline) + (set! cur-section args) #t)) +(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) + +(define test + (lambda (expect fun . args) + (write (cons fun args)) + (display " ==> ") + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (record-error (list res expect (cons fun args))) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) +(define (report-errs) + (newline) + (if (null? errs) (display "Passed all tests") + (begin + (display "errors were:") + (newline) + (display "(SECTION (got expected (call)))") + (newline) + (for-each (lambda (l) (write l) (newline)) + errs))) + (newline)) + +(SECTION 2 1);; test that all symbol characters are supported. +'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) + +(SECTION 3 4) +(define disjoint-type-functions + (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) +(define type-examples + (list + #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) +(define i 1) +(for-each (lambda (x) (display (make-string i #\ )) + (set! i (+ 3 i)) + (write x) + (newline)) + disjoint-type-functions) +(define type-matrix + (map (lambda (x) + (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) + (write t) + (write x) + (newline) + t)) + type-examples)) +(set! i 0) +(define j 0) +(for-each (lambda (x y) + (set! j (+ 1 j)) + (set! i 0) + (for-each (lambda (f) + (set! i (+ 1 i)) + (cond ((and (= i j)) + (cond ((not (f x))) (test #t f x))) + ((f x) (test #f f x))) + (cond ((and (= i j)) + (cond ((not (f y))) (test #t f y))) + ((f y) (test #f f y)))) + disjoint-type-functions)) + (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c)) + (list #f #\newline '() -3252 '(t . t) car "" 'nil '#())) +(SECTION 4 1 2) +(test '(quote a) 'quote (quote 'a)) +(test '(quote a) 'quote ''a) +(SECTION 4 1 3) +(test 12 (if #f + *) 3 4) +(SECTION 4 1 4) +(test 8 (lambda (x) (+ x x)) 4) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 reverse-subtract 7 10) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 add4 6) +(test '(3 4 5 6) (lambda x x) 3 4 5 6) +(test '(5 6) (lambda (x y . z) z) 3 4 5 6) +(SECTION 4 1 5) +(test 'yes 'if (if (> 3 2) 'yes 'no)) +(test 'no 'if (if (> 2 3) 'yes 'no)) +(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) +(SECTION 4 1 6) +(define x 2) +(test 3 'define (+ x 1)) +(set! x 4) +(test 5 'set! (+ x 1)) +(SECTION 4 2 1) +(test 'greater 'cond (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) +(test 'equal 'cond (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) +(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) +(test 'composite 'case (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) +(test 'consonant 'case (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) +(test #t 'and (and (= 2 2) (> 2 1))) +(test #f 'and (and (= 2 2) (< 2 1))) +(test '(f g) 'and (and 1 2 'c '(f g))) +(test #t 'and (and)) +(test #t 'or (or (= 2 2) (> 2 1))) +(test #t 'or (or (= 2 2) (< 2 1))) +(test #f 'or (or #f #f #f)) +(test #f 'or (or)) +(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) +(SECTION 4 2 2) +(test 6 'let (let ((x 2) (y 3)) (* x y))) +(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) +(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) +(test #t 'letrec (letrec ((even? + (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? + (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (even? 88))) +(define x 34) +(test 5 'let (let ((x 3)) (define x 5) x)) +(test 34 'let x) +(test 6 'let (let () (define x 6) x)) +(test 34 'let x) +(test 7 'let* (let* ((x 3)) (define x 7) x)) +(test 34 'let* x) +(test 8 'let* (let* () (define x 8) x)) +(test 34 'let* x) +(test 9 'letrec (letrec () (define x 9) x)) +(test 34 'letrec x) +(test 10 'letrec (letrec ((x 3)) (define x 10) x)) +(test 34 'letrec x) +(SECTION 4 2 3) +(define x 0) +(test 6 'begin (begin (set! x 5) (+ x 1))) +(SECTION 4 2 4) +(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) +(test 25 'do (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) +(test 1 'let (let foo () 1)) +(test '((6 1 3) (-5 -2)) 'let + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((negative? (car numbers)) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg))) + (else + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg))))) +(SECTION 4 2 6) +(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) +(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test '((foo 7) . cons) + 'quasiquote + `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) + +;;; sqt is defined here because not all implementations are required to +;;; support it. +(define (sqt x) + (do ((i 0 (+ i 1))) + ((> (* i i) x) (- i 1)))) + +(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) +(test 5 'quasiquote `,(+ 2 3)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) +(test '(a `(b ,x ,'y d) e) 'quasiquote + (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) +(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) +(SECTION 5 2 1) +(define add3 (lambda (x) (+ x 3))) +(test 6 'define (add3 3)) +(define first car) +(test 1 'define (first '(1 2))) +(define old-+ +) +(define + (lambda (x y) (list y x))) +(test '(3 6) add3 6) +(set! + old-+) +(test 9 add3 6) +(SECTION 5 2 2) +(test 45 'define + (let ((x 5)) + (define foo (lambda (y) (bar x y))) + (define bar (lambda (a b) (+ (* a b) a))) + (foo (+ x 3)))) +(define x 34) +(define (foo) (define x 5) x) +(test 5 foo) +(test 34 'define x) +(define foo (lambda () (define x 5) x)) +(test 5 foo) +(test 34 'define x) +(define (foo x) ((lambda () (define x 5) x)) x) +(test 88 foo 88) +(test 4 foo 4) +(test 34 'define x) +(SECTION 6 1) +(test #f not #t) +(test #f not 3) +(test #f not (list 3)) +(test #t not #f) +(test #f not '()) +(test #f not (list)) +(test #f not 'nil) + +;(test #t boolean? #f) +;(test #f boolean? 0) +;(test #f boolean? '()) +(SECTION 6 2) +(test #t eqv? 'a 'a) +(test #f eqv? 'a 'b) +(test #t eqv? 2 2) +(test #t eqv? '() '()) +(test #t eqv? '10000 '10000) +(test #f eqv? (cons 1 2)(cons 1 2)) +(test #f eqv? (lambda () 1) (lambda () 2)) +(test #f eqv? #f 'nil) +(let ((p (lambda (x) x))) + (test #t eqv? p p)) +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(let ((g (gen-counter))) (test #t eqv? g g)) +(test #f eqv? (gen-counter) (gen-counter)) +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (test #f eqv? f g)) + +(test #t eq? 'a 'a) +(test #f eq? (list 'a) (list 'a)) +(test #t eq? '() '()) +(test #t eq? car car) +(let ((x '(a))) (test #t eq? x x)) +(let ((x '#())) (test #t eq? x x)) +(let ((x (lambda (x) x))) (test #t eq? x x)) + +(test #t equal? 'a 'a) +(test #t equal? '(a) '(a)) +(test #t equal? '(a (b) c) '(a (b) c)) +(test #t equal? "abc" "abc") +(test #t equal? 2 2) +(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) +(SECTION 6 3) +(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) +(define x (list 'a 'b 'c)) +(define y x) +(and list? (test #t list? y)) +(set-cdr! x 4) +(test '(a . 4) 'set-cdr! x) +(test #t eqv? x y) +(test '(a b c . d) 'dot '(a . (b . (c . d)))) +(and list? (test #f list? y)) +(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) + +;(test #t pair? '(a . b)) +;(test #t pair? '(a . 1)) +;(test #t pair? '(a b c)) +;(test #f pair? '()) +;(test #f pair? '#(a b)) + +(test '(a) cons 'a '()) +(test '((a) b c d) cons '(a) '(b c d)) +(test '("a" b c) cons "a" '(b c)) +(test '(a . 3) cons 'a 3) +(test '((a b) . c) cons '(a b) 'c) + +(test 'a car '(a b c)) +(test '(a) car '((a) b c d)) +(test 1 car '(1 . 2)) + +(test '(b c d) cdr '((a) b c d)) +(test 2 cdr '(1 . 2)) + +(test '(a 7 c) list 'a (+ 3 4) 'c) +(test '() list) + +(test 3 length '(a b c)) +(test 3 length '(a (b) (c d e))) +(test 0 length '()) + +(test '(x y) append '(x) '(y)) +(test '(a b c d) append '(a) '(b c d)) +(test '(a (b) (c)) append '(a (b)) '((c))) +(test '() append) +(test '(a b c . d) append '(a b) '(c . d)) +(test 'a append '() 'a) + +(test '(c b a) reverse '(a b c)) +(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) + +(test 'c list-ref '(a b c d) 2) + +(test '(a b c) memq 'a '(a b c)) +(test '(b c) memq 'b '(a b c)) +(test '#f memq 'a '(b c d)) +(test '#f memq (list 'a) '(b (a) c)) +(test '((a) c) member (list 'a) '(b (a) c)) +(test '(101 102) memv 101 '(100 101 102)) + +(define e '((a 1) (b 2) (c 3))) +(test '(a 1) assq 'a e) +(test '(b 2) assq 'b e) +(test #f assq 'd e) +(test #f assq (list 'a) '(((a)) ((b)) ((c)))) +(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) +(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) +(SECTION 6 4) +;(test #t symbol? 'foo) +(test #t symbol? (car '(a b))) +;(test #f symbol? "bar") +;(test #t symbol? 'nil) +;(test #f symbol? '()) +;(test #f symbol? #f) +;;; But first, what case are symbols in? Determine the standard case: +(define char-standard-case char-upcase) +(if (string=? (symbol->string 'A) "a") + (set! char-standard-case char-downcase)) +(test #t 'standard-case + (string=? (symbol->string 'a) (symbol->string 'A))) +(test #t 'standard-case + (or (string=? (symbol->string 'a) "A") + (string=? (symbol->string 'A) "a"))) +(define (str-copy s) + (let ((v (make-string (string-length s)))) + (do ((i (- (string-length v) 1) (- i 1))) + ((< i 0) v) + (string-set! v i (string-ref s i))))) +(define (string-standard-case s) + (set! s (str-copy s)) + (do ((i 0 (+ 1 i)) + (sl (string-length s))) + ((>= i sl) s) + (string-set! s i (char-standard-case (string-ref s i))))) +(test (string-standard-case "flying-fish") symbol->string 'flying-fish) +(test (string-standard-case "martin") symbol->string 'Martin) +(test "Malvina" symbol->string (string->symbol "Malvina")) +(test #t 'standard-case (eq? 'a 'A)) + +(define x (string #\a #\b)) +(define y (string->symbol x)) +(string-set! x 0 #\c) +(test "cb" 'string-set! x) +(test "ab" symbol->string y) +(test y string->symbol "ab") + +(test #t eq? 'mISSISSIppi 'mississippi) +(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) +(test 'JollyWog string->symbol (symbol->string 'JollyWog)) + +(SECTION 6 5 5) +(test #t number? 3) +(test #t complex? 3) +(test #t real? 3) +(test #t rational? 3) +(test #t integer? 3) + +(test #t exact? 3) +(test #f inexact? 3) + +(test #t = 22 22 22) +(test #t = 22 22) +(test #f = 34 34 35) +(test #f = 34 35) +(test #t > 3 -6246) +(test #f > 9 9 -2424) +(test #t >= 3 -4 -6246) +(test #t >= 9 9) +(test #f >= 8 9) +(test #t < -1 2 3 4 5 6 7 8) +(test #f < -1 2 3 4 4 5 6 7) +(test #t <= -1 2 3 4 5 6 7 8) +(test #t <= -1 2 3 4 4 5 6 7) +(test #f < 1 3 2) +(test #f >= 1 3 2) + +(test #t zero? 0) +(test #f zero? 1) +(test #f zero? -1) +(test #f zero? -100) +(test #t positive? 4) +(test #f positive? -4) +(test #f positive? 0) +(test #f negative? 4) +(test #t negative? -4) +(test #f negative? 0) +(test #t odd? 3) +(test #f odd? 2) +(test #f odd? -4) +(test #t odd? -1) +(test #f even? 3) +(test #t even? 2) +(test #t even? -4) +(test #f even? -1) + +(test 38 max 34 5 7 38 6) +(test -24 min 3 5 5 330 4 -24) + +(test 7 + 3 4) +(test '3 + 3) +(test 0 +) +(test 4 * 4) +(test 1 *) + +(test -1 - 3 4) +(test -3 - 3) +(test 7 abs -7) +(test 7 abs 7) +(test 0 abs 0) + +(test 5 quotient 35 7) +(test -5 quotient -35 7) +(test -5 quotient 35 -7) +(test 5 quotient -35 -7) +(test 1 modulo 13 4) +(test 1 remainder 13 4) +(test 3 modulo -13 4) +(test -1 remainder -13 4) +(test -3 modulo 13 -4) +(test 1 remainder 13 -4) +(test -1 modulo -13 -4) +(test -1 remainder -13 -4) +(define (divtest n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2)))) +(test #t divtest 238 9) +(test #t divtest -238 9) +(test #t divtest 238 -9) +(test #t divtest -238 -9) + +(test 4 gcd 0 4) +(test 4 gcd -4 0) +(test 4 gcd 32 -36) +(test 0 gcd) +(test 288 lcm 32 -36) +(test 1 lcm) + +;;;;From: fred@sce.carleton.ca (Fred J Kaudel) +;;; Modified by jaffer. +(define (test-inexact) + (define f3.9 (string->number "3.9")) + (define f4.0 (string->number "4.0")) + (define f-3.25 (string->number "-3.25")) + (define f.25 (string->number ".25")) + (define f4.5 (string->number "4.5")) + (define f3.5 (string->number "3.5")) + (define f0.0 (string->number "0.0")) + (define f0.8 (string->number "0.8")) + (define f1.0 (string->number "1.0")) + (define wto write-test-obj) + (define dto display-test-obj) + (define lto load-test-obj) + (newline) + (display ";testing inexact numbers; ") + (newline) + (SECTION 6 5 5) + (test #t inexact? f3.9) + (test #t 'inexact? (inexact? (max f3.9 4))) + (test f4.0 'max (max f3.9 4)) + (test f4.0 'exact->inexact (exact->inexact 4)) + (test (- f4.0) round (- f4.5)) + (test (- f4.0) round (- f3.5)) + (test (- f4.0) round (- f3.9)) + (test f0.0 round f0.0) + (test f0.0 round f.25) + (test f1.0 round f0.8) + (test f4.0 round f3.5) + (test f4.0 round f4.5) + (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. + (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) + (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) + (test #t call-with-output-file + "tmp3" + (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) + (check-test-file "tmp3") + (set! write-test-obj wto) + (set! display-test-obj dto) + (set! load-test-obj lto) + (let ((x (string->number "4195835.0")) + (y (string->number "3145727.0"))) + (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) + (report-errs)) + +(define (test-bignum) + (define tb + (lambda (n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2))))) + (newline) + (display ";testing bignums; ") + (newline) + (SECTION 6 5 5) + (test 0 modulo 3333333333 3) + (test 0 modulo 3333333333 -3) + (test 0 remainder 3333333333 3) + (test 0 remainder 3333333333 -3) + (test 2 modulo 3333333332 3) + (test -1 modulo 3333333332 -3) + (test 2 remainder 3333333332 3) + (test 2 remainder 3333333332 -3) + (test 1 modulo -3333333332 3) + (test -2 modulo -3333333332 -3) + (test -2 remainder -3333333332 3) + (test -2 remainder -3333333332 -3) + + (test 3 modulo 3 3333333333) + (test 3333333330 modulo -3 3333333333) + (test 3 remainder 3 3333333333) + (test -3 remainder -3 3333333333) + (test -3333333330 modulo 3 -3333333333) + (test -3 modulo -3 -3333333333) + (test 3 remainder 3 -3333333333) + (test -3 remainder -3 -3333333333) + + (test 0 modulo -2177452800 86400) + (test 0 modulo 2177452800 -86400) + (test 0 modulo 2177452800 86400) + (test 0 modulo -2177452800 -86400) + (test #t 'remainder (tb 281474976710655 65535)) + (test #t 'remainder (tb 281474976710654 65535)) + (SECTION 6 5 6) + (test 281474976710655 string->number "281474976710655") + (test "281474976710655" number->string 281474976710655) + (report-errs)) + +(SECTION 6 5 6) +(test "0" number->string 0) +(test "100" number->string 100) +(test "100" number->string 256 16) +(test 100 string->number "100") +(test 256 string->number "100" 16) +(test #f string->number "") +(test #f string->number ".") +(test #f string->number "d") +(test #f string->number "D") +(test #f string->number "i") +(test #f string->number "I") +(test #f string->number "3i") +(test #f string->number "3I") +(test #f string->number "33i") +(test #f string->number "33I") +(test #f string->number "3.3i") +(test #f string->number "3.3I") +(test #f string->number "-") +(test #f string->number "+") + +(SECTION 6 6) +(test #t eqv? '#\ #\Space) +(test #t eqv? #\space '#\Space) +(test #t char? #\a) +(test #t char? #\() +(test #t char? #\ ) +(test #t char? '#\newline) + +(test #f char=? #\A #\B) +(test #f char=? #\a #\b) +(test #f char=? #\9 #\0) +(test #t char=? #\A #\A) + +(test #t char<? #\A #\B) +(test #t char<? #\a #\b) +(test #f char<? #\9 #\0) +(test #f char<? #\A #\A) + +(test #f char>? #\A #\B) +(test #f char>? #\a #\b) +(test #t char>? #\9 #\0) +(test #f char>? #\A #\A) + +(test #t char<=? #\A #\B) +(test #t char<=? #\a #\b) +(test #f char<=? #\9 #\0) +(test #t char<=? #\A #\A) + +(test #f char>=? #\A #\B) +(test #f char>=? #\a #\b) +(test #t char>=? #\9 #\0) +(test #t char>=? #\A #\A) + +(test #f char-ci=? #\A #\B) +(test #f char-ci=? #\a #\B) +(test #f char-ci=? #\A #\b) +(test #f char-ci=? #\a #\b) +(test #f char-ci=? #\9 #\0) +(test #t char-ci=? #\A #\A) +(test #t char-ci=? #\A #\a) + +(test #t char-ci<? #\A #\B) +(test #t char-ci<? #\a #\B) +(test #t char-ci<? #\A #\b) +(test #t char-ci<? #\a #\b) +(test #f char-ci<? #\9 #\0) +(test #f char-ci<? #\A #\A) +(test #f char-ci<? #\A #\a) + +(test #f char-ci>? #\A #\B) +(test #f char-ci>? #\a #\B) +(test #f char-ci>? #\A #\b) +(test #f char-ci>? #\a #\b) +(test #t char-ci>? #\9 #\0) +(test #f char-ci>? #\A #\A) +(test #f char-ci>? #\A #\a) + +(test #t char-ci<=? #\A #\B) +(test #t char-ci<=? #\a #\B) +(test #t char-ci<=? #\A #\b) +(test #t char-ci<=? #\a #\b) +(test #f char-ci<=? #\9 #\0) +(test #t char-ci<=? #\A #\A) +(test #t char-ci<=? #\A #\a) + +(test #f char-ci>=? #\A #\B) +(test #f char-ci>=? #\a #\B) +(test #f char-ci>=? #\A #\b) +(test #f char-ci>=? #\a #\b) +(test #t char-ci>=? #\9 #\0) +(test #t char-ci>=? #\A #\A) +(test #t char-ci>=? #\A #\a) + +(test #t char-alphabetic? #\a) +(test #t char-alphabetic? #\A) +(test #t char-alphabetic? #\z) +(test #t char-alphabetic? #\Z) +(test #f char-alphabetic? #\0) +(test #f char-alphabetic? #\9) +(test #f char-alphabetic? #\space) +(test #f char-alphabetic? #\;) + +(test #f char-numeric? #\a) +(test #f char-numeric? #\A) +(test #f char-numeric? #\z) +(test #f char-numeric? #\Z) +(test #t char-numeric? #\0) +(test #t char-numeric? #\9) +(test #f char-numeric? #\space) +(test #f char-numeric? #\;) + +(test #f char-whitespace? #\a) +(test #f char-whitespace? #\A) +(test #f char-whitespace? #\z) +(test #f char-whitespace? #\Z) +(test #f char-whitespace? #\0) +(test #f char-whitespace? #\9) +(test #t char-whitespace? #\space) +(test #f char-whitespace? #\;) + +(test #f char-upper-case? #\0) +(test #f char-upper-case? #\9) +(test #f char-upper-case? #\space) +(test #f char-upper-case? #\;) + +(test #f char-lower-case? #\0) +(test #f char-lower-case? #\9) +(test #f char-lower-case? #\space) +(test #f char-lower-case? #\;) + +(test #\. integer->char (char->integer #\.)) +(test #\A integer->char (char->integer #\A)) +(test #\a integer->char (char->integer #\a)) +(test #\A char-upcase #\A) +(test #\A char-upcase #\a) +(test #\a char-downcase #\A) +(test #\a char-downcase #\a) +(SECTION 6 7) +(test #t string? "The word \"recursion\\\" has many meanings.") +;(test #t string? "") +(define f (make-string 3 #\*)) +(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) +(test "abc" string #\a #\b #\c) +(test "" string) +(test 3 string-length "abc") +(test #\a string-ref "abc" 0) +(test #\c string-ref "abc" 2) +(test 0 string-length "") +(test "" substring "ab" 0 0) +(test "" substring "ab" 1 1) +(test "" substring "ab" 2 2) +(test "a" substring "ab" 0 1) +(test "b" substring "ab" 1 2) +(test "ab" substring "ab" 0 2) +(test "foobar" string-append "foo" "bar") +(test "foo" string-append "foo") +(test "foo" string-append "foo" "") +(test "foo" string-append "" "foo") +(test "" string-append) +(test "" make-string 0) +(test #t string=? "" "") +(test #f string<? "" "") +(test #f string>? "" "") +(test #t string<=? "" "") +(test #t string>=? "" "") +(test #t string-ci=? "" "") +(test #f string-ci<? "" "") +(test #f string-ci>? "" "") +(test #t string-ci<=? "" "") +(test #t string-ci>=? "" "") + +(test #f string=? "A" "B") +(test #f string=? "a" "b") +(test #f string=? "9" "0") +(test #t string=? "A" "A") + +(test #t string<? "A" "B") +(test #t string<? "a" "b") +(test #f string<? "9" "0") +(test #f string<? "A" "A") + +(test #f string>? "A" "B") +(test #f string>? "a" "b") +(test #t string>? "9" "0") +(test #f string>? "A" "A") + +(test #t string<=? "A" "B") +(test #t string<=? "a" "b") +(test #f string<=? "9" "0") +(test #t string<=? "A" "A") + +(test #f string>=? "A" "B") +(test #f string>=? "a" "b") +(test #t string>=? "9" "0") +(test #t string>=? "A" "A") + +(test #f string-ci=? "A" "B") +(test #f string-ci=? "a" "B") +(test #f string-ci=? "A" "b") +(test #f string-ci=? "a" "b") +(test #f string-ci=? "9" "0") +(test #t string-ci=? "A" "A") +(test #t string-ci=? "A" "a") + +(test #t string-ci<? "A" "B") +(test #t string-ci<? "a" "B") +(test #t string-ci<? "A" "b") +(test #t string-ci<? "a" "b") +(test #f string-ci<? "9" "0") +(test #f string-ci<? "A" "A") +(test #f string-ci<? "A" "a") + +(test #f string-ci>? "A" "B") +(test #f string-ci>? "a" "B") +(test #f string-ci>? "A" "b") +(test #f string-ci>? "a" "b") +(test #t string-ci>? "9" "0") +(test #f string-ci>? "A" "A") +(test #f string-ci>? "A" "a") + +(test #t string-ci<=? "A" "B") +(test #t string-ci<=? "a" "B") +(test #t string-ci<=? "A" "b") +(test #t string-ci<=? "a" "b") +(test #f string-ci<=? "9" "0") +(test #t string-ci<=? "A" "A") +(test #t string-ci<=? "A" "a") + +(test #f string-ci>=? "A" "B") +(test #f string-ci>=? "a" "B") +(test #f string-ci>=? "A" "b") +(test #f string-ci>=? "a" "b") +(test #t string-ci>=? "9" "0") +(test #t string-ci>=? "A" "A") +(test #t string-ci>=? "A" "a") +(SECTION 6 8) +(test #t vector? '#(0 (2 2 2 2) "Anna")) +;(test #t vector? '#()) +(test '#(a b c) vector 'a 'b 'c) +(test '#() vector) +(test 3 vector-length '#(0 (2 2 2 2) "Anna")) +(test 0 vector-length '#()) +(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) +(test '#(0 ("Sue" "Sue") "Anna") 'vector-set + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) +(test '#(hi hi) make-vector 2 'hi) +(test '#() make-vector 0) +(test '#() make-vector 0 'a) +(SECTION 6 9) +(test #t procedure? car) +;(test #f procedure? 'car) +(test #t procedure? (lambda (x) (* x x))) +(test #f procedure? '(lambda (x) (* x x))) +(test #t call-with-current-continuation procedure?) +(test 7 apply + (list 3 4)) +(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) +(test 17 apply + 10 (list 3 4)) +(test '() apply list '()) +(define compose (lambda (f g) (lambda args (f (apply g args))))) +(test 30 (compose sqt *) 12 75) + +(test '(b e h) map cadr '((a b) (d e) (g h))) +(test '(5 7 9) map + '(1 2 3) '(4 5 6)) +(test '#(0 1 4 9 16) 'for-each + (let ((v (make-vector 5))) + (for-each (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) +(test -3 call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x))) + '(54 0 37 -3 245 19)) + #t)) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r (lambda (obj) (cond ((null? obj) 0) + ((pair? obj) (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) +(test 4 list-length '(1 2 3 4)) +(test #f list-length '(a b . c)) +(test '() map cadr '()) + +;;; This tests full conformance of call-with-current-continuation. It +;;; is a separate test because some schemes do not support call/cc +;;; other than escape procedures. I am indebted to +;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this +;;; code. The function leaf-eq? compares the leaves of 2 arbitrary +;;; trees constructed of conses. +(define (next-leaf-generator obj eot) + (letrec ((return #f) + (cont (lambda (x) + (recur obj) + (set! cont (lambda (x) (return eot))) + (cont #f))) + (recur (lambda (obj) + (if (pair? obj) + (for-each recur obj) + (call-with-current-continuation + (lambda (c) + (set! cont c) + (return obj))))))) + (lambda () (call-with-current-continuation + (lambda (ret) (set! return ret) (cont #f)))))) +(define (leaf-eq? x y) + (let* ((eot (list 'eot)) + (xf (next-leaf-generator x eot)) + (yf (next-leaf-generator y eot))) + (letrec ((loop (lambda (x y) + (cond ((not (eq? x y)) #f) + ((eq? eot x) #t) + (else (loop (xf) (yf))))))) + (loop (xf) (yf))))) +(define (test-cont) + (newline) + (display ";testing continuations; ") + (newline) + (SECTION 6 9) + (test #t leaf-eq? '(a (b (c))) '((a) b c)) + (test #f leaf-eq? '(a (b (c))) '((a) b c d)) + (report-errs)) + +;;; Test Optional R4RS DELAY syntax and FORCE procedure +(define (test-delay) + (newline) + (display ";testing DELAY and FORCE; ") + (newline) + (SECTION 6 9) + (test 3 'delay (force (delay (+ 1 2)))) + (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + (test 2 'delay (letrec ((a-stream + (letrec ((next (lambda (n) + (cons n (delay (next (+ n 1))))))) + (next 0))) + (head car) + (tail (lambda (stream) (force (cdr stream))))) + (head (tail (tail a-stream))))) + (letrec ((count 0) + (p (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (x 5)) + (test 6 force p) + (set! x 10) + (test 6 force p)) + (test 3 'force + (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) + (c #f)) + (force p))) + (report-errs)) + +(SECTION 6 10 1) +(test #t input-port? (current-input-port)) +(test #t output-port? (current-output-port)) +(test #t call-with-input-file "r4rstest.scm" input-port?) +(define this-file (open-input-file "r4rstest.scm")) +(test #t input-port? this-file) +(SECTION 6 10 2) +(test #\; peek-char this-file) +(test #\; read-char this-file) +(test '(define cur-section '()) read this-file) +(test #\( peek-char this-file) +(test '(define errs '()) read this-file) +(close-input-port this-file) +(close-input-port this-file) +(define (check-test-file name) + (define test-file (open-input-file name)) + (test #t 'input-port? + (call-with-input-file + name + (lambda (test-file) + (test load-test-obj read test-file) + (test #t eof-object? (peek-char test-file)) + (test #t eof-object? (read-char test-file)) + (input-port? test-file)))) + (test #\; read-char test-file) + (test display-test-obj read test-file) + (test load-test-obj read test-file) + (close-input-port test-file)) +(SECTION 6 10 3) +(define write-test-obj + '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) +(define display-test-obj + '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) +(define load-test-obj + (list 'define 'foo (list 'quote write-test-obj))) +(test #t call-with-output-file + "tmp1" + (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))) +(check-test-file "tmp1") + +(define test-file (open-output-file "tmp2")) +(write-char #\; test-file) +(display write-test-obj test-file) +(newline test-file) +(write load-test-obj test-file) +(test #t output-port? test-file) +(close-output-port test-file) +(check-test-file "tmp2") +(define (test-sc4) + (newline) + (display ";testing scheme 4 functions; ") + (newline) + (SECTION 6 7) + (test '(#\P #\space #\l) string->list "P l") + (test '() string->list "") + (test "1\\\"" list->string '(#\1 #\\ #\")) + (test "" list->string '()) + (SECTION 6 8) + (test '(dah dah didah) vector->list '#(dah dah didah)) + (test '() vector->list '#()) + (test '#(dididit dah) list->vector '(dididit dah)) + (test '#() list->vector '()) + (SECTION 6 10 4) + (load "tmp1") + (test write-test-obj 'load foo) + (report-errs)) + +(report-errs) +(if (and (string->number "0.0") (inexact? (string->number "0.0"))) + (test-inexact)) + +(let ((n (string->number "281474976710655"))) + (if (and n (exact? n)) + (test-bignum))) +(newline) +(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:") +(newline) +(display "(test-cont) (test-sc4) (test-delay)") +(newline) +"last item in file" @@ -0,0 +1,1677 @@ +/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "ramap.c" Array mapping functions for APL-Scheme. + Author: Radey Shouman */ + +#include "scm.h" + +typedef struct { + char *name; + SCM sproc; + int (* vproc)(); +} ra_iproc; + +# define BVE_REF(a, i) ((VELTS(a)[(i)/LONG_BIT] & (1L<<((i)%LONG_BIT))) ? 1 : 0) +# define BVE_SET(a, i) (VELTS(a)[(i)/LONG_BIT] |= (1L<<((i)%LONG_BIT))) +# define BVE_CLR(a, i) (VELTS(a)[(i)/LONG_BIT] &= ~(1L<<((i)%LONG_BIT))) +/* Fast, recycling vector ref */ +# define RVREF(ra, i, e) (e = cvref(ra, i, e)) +/* #define RVREF(ra, i, e) (cvref(ra, i, UNDEFINED)) to turn off */ + +/* IVDEP means "ignore vector dependencies", meaning we guarantee that + elements of 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 sizet cind(ra, inds) + SCM ra, inds; +{ + sizet i; + int k; + long *ve = VELTS(inds); + if (!ARRAYP(ra)) + return *ve; + i = ARRAY_BASE(ra); + for (k = 0; k < ARRAY_NDIM(ra); k++) + i += (ve[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc; + return i; +} + + /* Checker for 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 ra_matchp(ra0, ras) + SCM ra0, ras; +{ + SCM ra1; + array_dim dims; + array_dim *s0 = &dims; + array_dim *s1; + sizet bas0 = 0; + int i, ndim = 1; + int exact = 2 /* 4 */; /* Don't care about values >2 (yet?) */ + if IMP(ra0) return 0; + switch TYP7(ra0) { + default: return 0; + case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: + case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + s0->lbnd = 0; + s0->inc = 1; + s0->ubnd = (long)LENGTH(ra0) - 1; + break; + case tc7_smob: + if (!ARRAYP(ra0)) return 0; + ndim = ARRAY_NDIM(ra0); + s0 = ARRAY_DIMS(ra0); + bas0 = ARRAY_BASE(ra0); + break; + } + while NIMP(ras) { + ra1 = CAR(ras); + switch (IMP(ra1) ? 0 : TYP7(ra1)) { + default: scalar: + CAR(ras) = sc2array(ra1,ra0,EOL); break; + case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: + case tc7_ivect: case tc7_fvect: case tc7_dvect: case 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==LENGTH(ra1) - 1)) break; + exact = 1; + case 1: if (s0->lbnd < 0 || s0->ubnd >= LENGTH(ra1)) + if (s0->lbnd <= s0->ubnd) return 0; + } + break; + case tc7_smob: + if (!ARRAYP(ra1)) goto scalar; + if (ndim != ARRAY_NDIM(ra1)) + if (0==ARRAY_NDIM(ra1)) + goto scalar; + else + return 0; + s1 = ARRAY_DIMS(ra1); + if (bas0 != 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) + if (s0[i].lbnd <= s0[i].ubnd) return 0; + } + break; + } + ras = CDR(ras); + } + return exact; +} + +static char s_ra_mismatch[] = "array shape mismatch"; +int ramapc(cproc, data, ra0, lra, what) + int (*cproc)(); + SCM data, ra0, lra; + char *what; +{ + SCM inds, z; + SCM vra0, ra1, vra1; + SCM lvra, *plvra; + long *vinds; + int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0); + switch (ra_matchp(ra0, lra)) { + default: + case 0: wta(ra0, s_ra_mismatch, what); + case 2: case 3: case 4: /* Try unrolling arrays */ + if (kmax < 0) goto gencase; + vra0 = (0==kmax ? ra0 : array_contents(ra0, UNDEFINED)); + if IMP(vra0) goto gencase; + if (!ARRAYP(vra0)) { + vra1 = make_ra(1); + ARRAY_BASE(vra1) = 0; + ARRAY_DIMS(vra1)->lbnd = 0; + ARRAY_DIMS(vra1)->ubnd = LENGTH(vra0) - 1; + ARRAY_DIMS(vra1)->inc = 1; + ARRAY_V(vra1) = vra0; + vra0 = vra1; + } + lvra = EOL; + plvra = &lvra; + for (z = lra; NIMP(z); z = CDR(z)) { + vra1 = ra1 = (0==kmax ? CAR(z) : array_contents(CAR(z), UNDEFINED)); + if FALSEP(ra1) goto gencase; + if (!ARRAYP(ra1)) { + vra1 = make_ra(1); + ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; + ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd; + ARRAY_BASE(vra1) = 0; + ARRAY_DIMS(vra1)->inc = 1; + ARRAY_V(vra1) = ra1; + } + *plvra = cons(vra1, EOL); + plvra = &CDR(*plvra); + } + return (UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); + case 1: gencase: /* Have to loop over all dimensions. */ + vra0 = make_ra(1); + if ARRAYP(ra0) { + if (kmax < 0) { + ARRAY_DIMS(vra0)->lbnd = 0; + ARRAY_DIMS(vra0)->ubnd = 0; + ARRAY_DIMS(vra0)->inc = 1; + } + else { + ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd; + ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd; + ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc; + } + ARRAY_BASE(vra0) = ARRAY_BASE(ra0); + ARRAY_V(vra0) = ARRAY_V(ra0); + } + else { + ARRAY_DIMS(vra0)->lbnd = 0; + ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1; + ARRAY_DIMS(vra0)->inc = 1; + ARRAY_BASE(vra0) = 0; + ARRAY_V(vra0) = ra0; + ra0 = vra0; + } + lvra = EOL; + plvra = &lvra; + for (z = lra; NIMP(z); z = CDR(z)) { + ra1 = CAR(z); + vra1 = make_ra(1); + ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd; + ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd; + if ARRAYP(ra1) { + if (kmax >= 0) + ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc; + ARRAY_V(vra1) = ARRAY_V(ra1); + } + else { + ARRAY_DIMS(vra1)->inc = 1; + ARRAY_V(vra1) = ra1; + } + *plvra = cons(vra1, EOL); + plvra = &CDR(*plvra); + } + inds = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-1L)); + vinds = (long *)VELTS(inds); + for (k = 0; k <= kmax; k++) + vinds[k] = ARRAY_DIMS(ra0)[k].lbnd; + k = kmax; + do { + if (k==kmax) { + SCM y = lra; + ARRAY_BASE(vra0) = cind(ra0, inds); + for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y)) + ARRAY_BASE(CAR(z)) = cind(CAR(y), inds); + if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) + return 0; + k--; + continue; + } + if (vinds[k] < ARRAY_DIMS(ra0)[k].ubnd) { + vinds[k]++; + k++; + continue; + } + vinds[k] = ARRAY_DIMS(ra0)[k].lbnd - 1; + k--; + } while (k >= 0); + return 1; + } +} + +static char s_array_fill[] = "array-fill!"; +SCM array_fill(ra, fill) + SCM ra, fill; +{ + ramapc(rafill, fill, ra, EOL, s_array_fill); + return UNSPECIFIED; +} + +static char s_sarray_copy[] = "serial-array-copy!"; +# define s_array_copy (s_sarray_copy + 7) +static int racp(src, dst) + SCM dst, src; +{ + long n = (ARRAY_DIMS(src)->ubnd - ARRAY_DIMS(src)->lbnd + 1); + long inc_d, inc_s = ARRAY_DIMS(src)->inc; + sizet i_d, i_s = ARRAY_BASE(src); + dst = CAR(dst); + inc_d = ARRAY_DIMS(dst)->inc; + i_d = ARRAY_BASE(dst); + src = ARRAY_V(src); + dst = ARRAY_V(dst); + switch TYP7(dst) { + default: gencase: case tc7_vector: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + aset(dst, cvref(src, i_s, UNDEFINED), MAKINUM(i_d)); + break; + case tc7_string: if (tc7_string != TYP7(dst)) goto gencase; + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + CHARS(dst)[i_d] = CHARS(src)[i_s]; + break; + case tc7_bvect: if (tc7_bvect != TYP7(dst)) goto gencase; + if (1==inc_d && 1==inc_s && i_s%LONG_BIT==i_d%LONG_BIT && n>=LONG_BIT) { + long *sv = (long *)VELTS(src); + long *dv = (long *)VELTS(dst); + sv += i_s/LONG_BIT; + dv += i_d/LONG_BIT; + if (i_s % LONG_BIT) { /* leading partial word */ + *dv = (*dv & ~(~0L<<(i_s%LONG_BIT))) | (*sv & (~0L<<(i_s%LONG_BIT))); + dv++; + sv++; + n -= LONG_BIT - (i_s % LONG_BIT); + } + IVDEP(src != dst, + for (; n >= LONG_BIT; n -= 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 (VELTS(src)[i_s/LONG_BIT] & (1L << (i_s%LONG_BIT))) + VELTS(dst)[i_d/LONG_BIT] |= (1L << (i_d%LONG_BIT)); + else + VELTS(dst)[i_d/LONG_BIT] &= ~(1L << (i_d%LONG_BIT)); + } + break; + case tc7_uvect: + case tc7_ivect: { + long *d = (long *)VELTS(dst), *s = (long *)VELTS(src); + if (TYP7(src)==TYP7(dst)) { + IVDEP(src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s];) + } + else if (tc7_ivect==TYP7(dst)) + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = num2long(cvref(src, i_s, UNDEFINED), + (char *)ARG2, s_array_copy); + else + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = num2ulong(cvref(src, i_s, UNDEFINED), + (char *)ARG2, s_array_copy); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *d = (float *)VELTS(dst); + float *s = (float *)VELTS(src); + switch TYP7(src) { + default: goto gencase; + case tc7_ivect: case 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 tc7_fvect: + IVDEP(src != dst, + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s]; ) + break; + case 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 /* SINGLES */ + case tc7_dvect: { + double *d = (double *)VELTS(dst); + double *s = (double *)VELTS(src); + switch TYP7(src) { + default: goto gencase; + case tc7_ivect: case 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 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 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 tc7_cvect: { + double (*d)[2] = (double (*)[2])VELTS(dst); + double (*s)[2] = (double (*)[2])VELTS(src); + switch TYP7(src) { + default: goto gencase; + case tc7_ivect: case 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 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 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 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 /* FLOATS */ + } + return 1; +} +SCM array_copy(src, dst) + SCM src; + SCM dst; +{ +#ifndef RECKLESS + if (INUM0==array_rank(dst)) + ASSERT(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src), + dst, ARG2, s_array_copy); +#endif + ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy); + return UNSPECIFIED; +} + +SCM ra2contig(ra, copy) + SCM ra; + int copy; +{ + SCM ret; + long inc = 1; + sizet k, len = 1; + for (k = ARRAY_NDIM(ra); k--;) + len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1; + k = ARRAY_NDIM(ra); + if (ARRAY_CONTP(ra) && ((0==k) || (1==ARRAY_DIMS(ra)[k-1].inc))) { + if (tc7_bvect != TYP7(ARRAY_V(ra))) + return ra; + if ((len==LENGTH(ARRAY_V(ra)) && + 0==ARRAY_BASE(ra) % LONG_BIT && + 0==len % LONG_BIT)) + return ra; + } + ret = make_ra(k); + ARRAY_BASE(ret) = 0; + while (k--) { + ARRAY_DIMS(ret)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd; + ARRAY_DIMS(ret)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd; + ARRAY_DIMS(ret)[k].inc = inc; + inc *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1; + } + CAR(ret) |= ARRAY_CONTIGUOUS; + ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra)); + if (copy) array_copy(ra, ret); + return ret; +} + +static char s_ura_rd[] = "uniform-array-read!"; +SCM ura_read(ra, port) + SCM ra, port; +{ + SCM ret, cra; + if (NIMP(ra) && ARRAYP(ra)) { + cra = ra2contig(ra, 0); + ret = uve_read(cra, port); + if (cra != ra) array_copy(cra, ra); + return ret; + } + else return uve_read(ra, port); +} + +static char s_ura_wr[] = "uniform-array-write"; +SCM ura_write(ra, port) + SCM ra, port; +{ + if (NIMP(ra) && ARRAYP(ra)) + return uve_write(ra2contig(ra,1), port); + else + return uve_write(ra, port); +} + +static char s_sc2array[] = "scalar->array"; +SCM sc2array(s, ra, prot) + SCM s, ra, prot; +{ + SCM res; + ASSERT(NIMP(ra), ra, ARG2, s_sc2array); + if ARRAYP(ra) { + int k = ARRAY_NDIM(ra); + res = make_ra(k); + while (k--) { + ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd; + ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd; + ARRAY_DIMS(res)[k].inc = 0; + } + ra = ARRAY_V(ra); + } + else { + ASSERT(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array); + res = make_ra(1); + ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1; + ARRAY_DIMS(res)->lbnd = 0; + ARRAY_DIMS(res)->inc = 0; + } + if (NIMP(s) && ARRAYP(s) && 0==ARRAY_NDIM(s)) { + ARRAY_BASE(res) = ARRAY_BASE(s); + ARRAY_V(res) = ARRAY_V(s); + return res; + } + ARRAY_BASE(res) = 0; + ARRAY_V(res) = make_uve(1L, NULLP(prot) ? array_prot(ra) : CAR(prot)); + switch TYP7(ARRAY_V(res)) { + case tc7_vector: + break; + case tc7_string: + if ICHRP(s) break; + goto mismatch; + case tc7_uvect: + if (INUMP(s) && INUM(s)>=0) break; +#ifdef BIGDIG + if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break; +#endif + goto mismatch; + case tc7_ivect: + if INUMP(s) break; +#ifdef BIGDIG + if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break; +#endif + goto mismatch; +#ifdef FLOATS +#ifdef SINGLES + case tc7_fvect: +#endif + case tc7_dvect: + if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break; + goto mismatch; + case tc7_cvect: + if NUMBERP(s) break; + goto mismatch; +#endif + mismatch: ARRAY_V(res) = make_vector(MAKINUM(1), s); + return res; + } + aset(ARRAY_V(res), s, INUM0); + return res; +} + +/* Functions callable by ARRAY-MAP! */ +int ra_eqp(ra0, ras) + SCM ra0, ras; +{ + SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras)); + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2); + long inc0 = ARRAY_DIMS(ra0)->inc; + long inc1 = ARRAY_DIMS(ra1)->inc; + long inc2 = ARRAY_DIMS(ra2)->inc; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + ra2 = ARRAY_V(ra2); + switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) { + default: { + SCM e1 = UNDEFINED, e2 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) + BVE_CLR(ra0, i0); + break; + } + case tc7_uvect: + case tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2]) + BVE_CLR(ra0, i0); + break; +# endif /*SINGLES*/ + case tc7_dvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2]) + BVE_CLR(ra0, i0); + break; + case tc7_cvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] || + ((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1]) + BVE_CLR(ra0, i0); + break; +# endif /*FLOATS*/ + } + return 1; +} +/* opt 0 means <, nonzero means >= */ +static int ra_compare(ra0, ra1, ra2, opt) + SCM ra0, ra1, ra2; + int opt; +{ + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2); + long inc0 = ARRAY_DIMS(ra0)->inc; + long inc1 = ARRAY_DIMS(ra1)->inc; + long inc2 = ARRAY_DIMS(ra2)->inc; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + ra2 = ARRAY_V(ra2); + switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) { + default: { + SCM e1 = UNDEFINED, e2 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (opt ? + NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) : + FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) ) + BVE_CLR(ra0, i0); + break; + } + case tc7_uvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { + if BVE_REF(ra0, i0) + if (opt ? + ((unsigned long*)VELTS(ra1))[i1] < ((unsigned long*)VELTS(ra2))[i2] : + ((unsigned long*)VELTS(ra1))[i1] >= ((unsigned long*)VELTS(ra2))[i2]) + BVE_CLR(ra0, i0); + } + break; + case tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { + if BVE_REF(ra0, i0) + if (opt ? + VELTS(ra1)[i1] < VELTS(ra2)[i2] : + VELTS(ra1)[i1] >= VELTS(ra2)[i2]) + BVE_CLR(ra0, i0); + } + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (opt ? + ((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] : + ((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2]) + BVE_CLR(ra0, i0); + break; +# endif /*SINGLES*/ + case tc7_dvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if (opt ? + ((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] : + ((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2]) + BVE_CLR(ra0, i0); + break; +# endif /*FLOATS*/ + } + return 1; +} +int ra_lessp(ra0, ras) + SCM ra0, ras; +{ + return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 0); +} +int ra_leqp(ra0, ras) + SCM ra0, ras; +{ + return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 1); +} +int ra_grp(ra0, ras) + SCM ra0, ras; +{ + return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 0); +} +int ra_greqp(ra0, ras) + SCM ra0, ras; +{ + return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 1); +} + +int ra_sum(ra0, ras) + SCM ra0, ras; +{ + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + if NNULLP(ras) { + SCM ra1 = CAR(ras); + sizet i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) { + ovflow: wta(ra0, (char *)OVFLOW, "+"); + default: { + SCM e0 = UNDEFINED, e1 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, sum(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), + MAKINUM(i0)); + break; + } + case tc7_uvect: { + unsigned long r; + unsigned long *v0 = (unsigned long *)VELTS(ra0); + unsigned long *v1 = (unsigned long *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] + v1[i1]; + ASRTGO(r >= v0[i0], ovflow); /* Will prevent vectorization */ + v0[i0] = r; + } ); + break; + } + case tc7_ivect: { + long r, *v0 = (long *)VELTS(ra0), *v1 = (long *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] + v1[i1]; + ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]<0 : r<=0 || v1[i1]>0), ovflow); + v0[i0] = r; + } ); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + float *v1 = (float *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] += v1[i1]); + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + double *v1 = (double *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] += v1[i1]); + break; + } + case tc7_cvect: { + double (*v0)[2] = (double (*)[2])VELTS(ra0); + double (*v1)[2] = (double (*)[2])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 /* FLOATS */ + } + } + return 1; +} + +int ra_difference(ra0, ras) + SCM ra0, ras; +{ + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + if NULLP(ras) { + switch TYP7(ra0) { + default: { + SCM e0 = UNDEFINED; + for (; n-- > 0; i0 += inc0) + aset(ra0, difference(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0)); + break; + } + case tc7_ivect: { + long *v0 = VELTS(ra0); + for (; n-- > 0; i0 += inc0) + v0[i0] = -v0[i0]; + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + for (; n-- > 0; i0 += inc0) + v0[i0] = -v0[i0]; + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + for (; n-- > 0; i0 += inc0) + v0[i0] = -v0[i0]; + break; + } + case tc7_cvect: { + double (*v0)[2] = (double (*)[2])VELTS(ra0); + for (; n-- > 0; i0 += inc0) { + v0[i0][0] = -v0[i0][0]; + v0[i0][1] = -v0[i0][1]; + } + break; + } +# endif /* FLOATS */ + } + } + else { + SCM ra1 = CAR(ras); + sizet i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) { + ovflow: wta(ra0, (char *)OVFLOW, "-"); + default: { + SCM e0 = UNDEFINED, e1 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, difference(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0)); + break; + } + case tc7_uvect: { + unsigned long r; + unsigned long *v0 = (unsigned long *)VELTS(ra0); + unsigned long *v1 = (unsigned long*)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] - v1[i1]; + ASRTGO(r <= v0[i0], ovflow); + v0[i0] = r; + } ); + break; + } + case tc7_ivect: { + long r, *v0 = VELTS(ra0), *v1 = VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] - v1[i1]; + ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]>0 : r<=0 || v1[i1]<0), ovflow); + v0[i0] = r; + } ); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + float *v1 = (float *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] -= v1[i1]); + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + double *v1 = (double *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] -= v1[i1]); + break; + } + case tc7_cvect: { + double (*v0)[2] = (double (*)[2])VELTS(ra0); + double (*v1)[2] = (double (*)[2])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 /* FLOATS */ + } + } + return 1; +} + +int ra_product(ra0, ras) + SCM ra0, ras; +{ + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + if NNULLP(ras) { + SCM ra1 = CAR(ras); + sizet i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) { + ovflow: wta(ra0, (char *)OVFLOW, "*"); + default: { + SCM e0 = UNDEFINED, e1 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, product(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), + MAKINUM(i0)); + break; + } + case tc7_uvect: { + unsigned long r; + unsigned long *v0 = (unsigned long *)VELTS(ra0); + unsigned long *v1 = (unsigned long *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] * v1[i1]; + ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow); + v0[i0] = r; + } ); + break; + } + case tc7_ivect: { + long r, *v0 = VELTS(ra0), *v1 =VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) { + r = v0[i0] * v1[i1]; + ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow); + v0[i0] = r; + } ); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + float *v1 = (float *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] *= v1[i1]); + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + double *v1 = (double *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] *= v1[i1]); + break; + } + case tc7_cvect: { + double (*v0)[2] = (double (*)[2])VELTS(ra0); + register double r; + double (*v1)[2] = (double (*)[2])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 /* FLOATS */ + } + } + return 1; +} +int ra_divide(ra0, ras) + SCM ra0, ras; +{ + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + if NULLP(ras) { + switch TYP7(ra0) { + default: { + SCM e0 = UNDEFINED; + for (; n-- > 0; i0 += inc0) + aset(ra0, divide(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0)); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + for (; n-- > 0; i0 += inc0) + v0[i0] = 1.0/v0[i0]; + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + for (; n-- > 0; i0 += inc0) + v0[i0] = 1.0/v0[i0]; + break; + } + case tc7_cvect: { + register double d; + double (*v0)[2] = (double (*)[2])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 /* FLOATS */ + } + } + else { + SCM ra1 = CAR(ras); + sizet i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) { + default: { + SCM e0 = UNDEFINED, e1 = UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, divide(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0)); + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0); + float *v1 = (float *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] /= v1[i1]); + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0); + double *v1 = (double *)VELTS(ra1); + IVDEP(ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + v0[i0] /= v1[i1]); + break; + } + case tc7_cvect: { + register double d, r; + double (*v0)[2] = (double (*)[2])VELTS(ra0); + double (*v1)[2] = (double (*)[2])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 /* FLOATS */ + } + } + return 1; +} +static int ra_identity(dst, src) + SCM src, dst; +{ + return racp(CAR(src), cons(dst, EOL)); +} + +static int ramap(ra0, proc, ras) + SCM ra0, proc, ras; +{ + long i = ARRAY_DIMS(ra0)->lbnd; + long inc = ARRAY_DIMS(ra0)->inc; + long n = ARRAY_DIMS(ra0)->ubnd; + long base = ARRAY_BASE(ra0) - i*inc; + ra0 = ARRAY_V(ra0); + if NULLP(ras) + for (; i <= n; i++) + aset(ra0, apply(proc, EOL, EOL), MAKINUM(i*inc + base)); + else { + SCM ra1 = CAR(ras); + SCM args, *ve = &ras; + sizet k, i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + ras = CDR(ras); + if NULLP(ras) + ras = nullvect; + else { + ras = vector(ras); + ve = VELTS(ras); + } + for (; i <= n; i++, i1 += inc1) { + args = EOL; + for (k = LENGTH(ras); k--;) + args = cons(aref(ve[k], MAKINUM(i)), args); + args = cons(cvref(ra1, i1, UNDEFINED), args); + aset(ra0, apply(proc, args, EOL), MAKINUM(i*inc + base)); + } + } + return 1; +} +static int ramap_cxr(ra0, proc, ras) + SCM ra0, proc, ras; +{ + SCM ra1 = CAR(ras); + SCM e1 = UNDEFINED; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1); + long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc; + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra1)->lbnd + 1; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + switch TYP7(ra0) { + default: gencase: + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, apply(proc, RVREF(ra1, i1, e1), listofnull), MAKINUM(i0)); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *dst = (float *)VELTS(ra0); + switch TYP7(ra1) { + default: goto gencase; + case tc7_fvect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = DSUBRF(proc)((double)((float *)VELTS(ra1))[i1]); + break; + case tc7_uvect: + case tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]); + break; + } + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *dst = (double *)VELTS(ra0); + switch TYP7(ra1) { + default: goto gencase; + case tc7_dvect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = DSUBRF(proc)(((double *)VELTS(ra1))[i1]); + break; + case tc7_uvect: + case tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]); + break; + } + break; + } +# endif /* FLOATS */ + } + return 1; +} +static int ramap_rp(ra0, proc, ras) + SCM ra0, proc, ras; +{ + SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras)); + SCM e1 = UNDEFINED, e2 = UNDEFINED; + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2); + long inc0 = ARRAY_DIMS(ra0)->inc; + long inc1 = ARRAY_DIMS(ra1)->inc; + long inc2 = ARRAY_DIMS(ra2)->inc; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + ra2 = ARRAY_V(ra2); + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if BVE_REF(ra0, i0) + if FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) + BVE_CLR(ra0, i0); + return 1; +} +static int ramap_1(ra0, proc, ras) + SCM ra0, proc, ras; +{ + SCM ra1 = CAR(ras); + SCM e1 = UNDEFINED; + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1); + long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + if (tc7_vector==TYP7(ra0)) + for (; n-- > 0; i0 += inc0, i1 += inc1) + VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED)); + else + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1)), MAKINUM(i0)); + return 1; +} +static int ramap_2o(ra0, proc, ras) + SCM ra0, proc, ras; +{ + SCM ra1 = CAR(ras); + SCM e1 = UNDEFINED; + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1); + long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc; + ra0 = ARRAY_V(ra0); + ra1 = ARRAY_V(ra1); + ras = CDR(ras); + if NULLP(ras) { + if (tc7_vector==TYP7(ra0)) + for (; n-- > 0; i0 += inc0, i1 += inc1) + VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED); + else + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1), UNDEFINED), + MAKINUM(i0)); + } + else { + SCM ra2 = CAR(ras); + SCM e2 = UNDEFINED; + sizet i2 = ARRAY_BASE(ra2); + long inc2 = ARRAY_DIMS(ra2)->inc; + ra2 = ARRAY_V(ra2); + if (tc7_vector==TYP7(ra0)) + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + VELTS(ra0)[i0] = + SUBRF(proc)(cvref(ra1, i1, UNDEFINED), cvref(ra2, i2, UNDEFINED)); + else + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + aset(ra0, + SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)), + MAKINUM(i0)); + } + return 1; +} +static int ramap_a(ra0, proc, ras) + SCM ra0, proc, ras; +{ + SCM e0 = UNDEFINED, e1 = UNDEFINED; + long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + if NULLP(ras) + for (; n-- > 0; i0 += inc0) + aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0)); + else { + SCM ra1 = CAR(ras); + sizet i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + for (; n-- > 0; i0 += inc0, i1 += inc1) + aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), + MAKINUM(i0)); + } + return 1; +} + +/* 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 CAR of all subrs (like those selected by SMOBNUM) to hold an + offset into a table of vectorized subrs. */ + +static ra_iproc ra_rpsubrs[] = { + {"=", UNDEFINED, ra_eqp}, + {"<", UNDEFINED, ra_lessp}, + {"<=", UNDEFINED, ra_leqp}, + {">", UNDEFINED, ra_grp}, + {">=", UNDEFINED, ra_greqp}, + {0, 0, 0}}; +static ra_iproc ra_asubrs[] = { + {"+", UNDEFINED, ra_sum}, + {"-", UNDEFINED, ra_difference}, + {"*", UNDEFINED, ra_product}, + {"/", UNDEFINED, ra_divide}, + {0, 0, 0}}; + +static char s_sarray_map[] = "serial-array-map!"; +# define s_array_map (s_sarray_map + 7) +SCM array_map(ra0, proc, lra) + SCM ra0, proc, lra; +{ + int narg = ilength(lra); + ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map); + tail: + switch TYP7(proc) { + wna: wta(UNDEFINED, (char *)WNA, s_array_map); + default: gencase: + ramapc(ramap, proc, ra0, lra, s_array_map); + return UNSPECIFIED; + case tc7_subr_1: ASRTGO(1==narg, wna); + ramapc(ramap_1, proc, ra0, lra, s_array_map); + return UNSPECIFIED; + case tc7_subr_2: ASRTGO(2==narg, wna); + case tc7_subr_2o: ASRTGO(2>=narg, wna); + ramapc(ramap_2o, proc, ra0, lra, s_array_map); + return UNSPECIFIED; + case tc7_cxr: if (! SUBRF(proc)) goto gencase; + ASRTGO(1==narg, wna); + ramapc(ramap_cxr, proc, ra0, lra, s_array_map); + return UNSPECIFIED; + case tc7_rpsubr: { + ra_iproc *p; + if (FALSEP(arrayp(ra0, BOOL_T))) goto gencase; + array_fill(ra0, BOOL_T); + for (p = ra_rpsubrs; p->name; p++) + if (proc==p->sproc) { + while (NNULLP(lra) && NNULLP(CDR(lra))) { + ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map); + lra = CDR(lra); + } + return UNSPECIFIED; + } + while (NNULLP(lra) && NNULLP(CDR(lra))) { + ramapc(ramap_rp, proc, ra0, lra, s_array_map); + lra = CDR(lra); + } + return UNSPECIFIED; + } + case tc7_asubr: + if NULLP(lra) { + SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED); + if INUMP(fill) { + prot = array_prot(ra0); +# ifdef FLOATS + if (NIMP(prot) && INEXP(prot)) + fill = makdbl((double)INUM(fill), 0.0); +# endif + } + array_fill(ra0, fill); + } + else { + SCM tail, ra1 = CAR(lra); + SCM v0 = (NIMP(ra0) && ARRAYP(ra0) ? 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 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1))) + if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0))) + goto gencase; + for (tail = CDR(lra); NNULLP(tail); tail = CDR(tail)) { + ra1 = CAR(tail); + if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1))) + goto gencase; + } + for (p = ra_asubrs; p->name; p++) + if (proc==p->sproc) { + if (ra0 != CAR(lra)) + ramapc(ra_identity, UNDEFINED, ra0, cons(CAR(lra), EOL), s_array_map); + lra = CDR(lra); + while (1) { + ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map); + if (IMP(lra) || IMP(CDR(lra))) return UNSPECIFIED; + lra = CDR(lra); + } + } + ramapc(ramap_2o, proc, ra0, lra, s_array_map); + lra = CDR(lra); + if NIMP(lra) + for (lra = CDR(lra); NIMP(lra); lra = CDR(lra)) + ramapc(ramap_a, proc, ra0, lra, s_array_map); + } + return UNSPECIFIED; +#ifdef CCLO + case tc7_cclo: + lra = cons(sc2array(proc,ra0,EOL), lra); + proc = CCLO_SUBR(proc); + goto tail; +#endif + } +} + +static int rafe(ra0, proc, ras) + SCM ra0, proc, ras; +{ + long i = ARRAY_DIMS(ra0)->lbnd; + sizet i0 = ARRAY_BASE(ra0); + long inc0 = ARRAY_DIMS(ra0)->inc; + long n = ARRAY_DIMS(ra0)->ubnd; + ra0 = ARRAY_V(ra0); + if NULLP(ras) + for (; i <= n; i++, i0 += inc0) + apply(proc, cvref(ra0, i0, UNDEFINED), listofnull); + else { + SCM ra1 = CAR(ras); + SCM args, *ve = &ras; + sizet k, i1 = ARRAY_BASE(ra1); + long inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + ras = CDR(ras); + if NULLP(ras) + ras = nullvect; + else { + ras = vector(ras); + ve = VELTS(ras); + } + for (; i <= n; i++, i0 += inc0, i1 += inc1) { + args = EOL; + for (k = LENGTH(ras); k--;) + args = cons(aref(ve[k], MAKINUM(i)), args); + args = cons2(cvref(ra0, i0, UNDEFINED), cvref(ra1, i1, UNDEFINED), args); + apply(proc, args, EOL); + } + } + return 1; +} +static char s_array_for_each[] = "array-for-each"; +SCM array_for_each(proc, ra0, lra) + SCM proc, ra0, lra; +{ + ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each); + tail: + switch TYP7(proc) { + default: + ramapc(rafe, proc, ra0, lra, s_array_for_each); + return UNSPECIFIED; +#ifdef CCLO + case tc7_cclo: + lra = cons(ra0, lra); + ra0 = sc2array(proc, ra0, EOL); + proc = CCLO_SUBR(proc); + goto tail; +#endif + } +} + +static char s_array_imap[] = "array-index-map!"; +SCM array_imap(ra, proc) + SCM ra, proc; +{ + sizet i; + ASSERT(NIMP(ra), ra, ARG1, s_array_imap); + ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap); + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_array_imap); + case tc7_vector: + { + SCM *ve = VELTS(ra); + for (i = 0; i < LENGTH(ra); i++) + ve[i] = apply(proc, MAKINUM(i), listofnull); + return UNSPECIFIED; + } + case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: + for (i = 0; i < LENGTH(ra); i++) + aset(ra, apply(proc, MAKINUM(i), listofnull), MAKINUM(i)); + return UNSPECIFIED; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + { + SCM args = EOL; + SCM inds = make_uve(ARRAY_NDIM(ra)+0L, MAKINUM(-1L)); + long *vinds = VELTS(inds); + int j, k, kmax = ARRAY_NDIM(ra) - 1; + for (k = 0; k <= kmax; k++) + vinds[k] = ARRAY_DIMS(ra)[k].lbnd; + k = kmax; + do { + if (k==kmax) { + vinds[k] = ARRAY_DIMS(ra)[k].lbnd; + i = cind(ra, inds); + for (; vinds[k] <= ARRAY_DIMS(ra)[k].ubnd; vinds[k]++) { + for (j = kmax+1, args = EOL; j--;) + args = cons(MAKINUM(vinds[j]), args); + aset(ARRAY_V(ra), apply(proc, args, EOL), MAKINUM(i)); + i += ARRAY_DIMS(ra)[k].inc; + } + k--; + continue; + } + if (vinds[k] < ARRAY_DIMS(ra)[k].ubnd) { + vinds[k]++; + k++; + continue; + } + vinds[k] = ARRAY_DIMS(ra)[k].lbnd - 1; + k--; + } while (k >= 0); + return UNSPECIFIED; + } + } +} + +SCM array_equal P((SCM ra0, SCM ra1)); +static int raeql_1(ra0, as_equal, ra1) + SCM ra0, as_equal, ra1; +{ + SCM e0 = UNDEFINED, e1 = UNDEFINED; + sizet i0 = 0, i1 = 0; + long inc0 = 1, inc1 = 1; + sizet n = LENGTH(ra0); + ra1 = CAR(ra1); + if ARRAYP(ra0) { + n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1; + i0 = ARRAY_BASE(ra0); + inc0 = ARRAY_DIMS(ra0)->inc; + ra0 = ARRAY_V(ra0); + } + if ARRAYP(ra1) { + i1 = ARRAY_BASE(ra1); + inc1 = ARRAY_DIMS(ra1)->inc; + ra1 = ARRAY_V(ra1); + } + switch TYP7(ra0) { + case tc7_vector: default: + for (; n--; i0+=inc0, i1+=inc1) { + if FALSEP(as_equal) { + if FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))) + return 0; + } + else + if FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))) + return 0; + } + return 1; + case tc7_string: { + char *v0 = CHARS(ra0) + i0; + char *v1 = CHARS(ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) return 0; + return 1; + } + case tc7_bvect: + for (; n--; i0 += inc0, i1 += inc1) + if (BVE_REF(ra0, i0) != BVE_REF(ra1, i1)) return 0; + return 1; + case tc7_uvect: case tc7_ivect: { + long *v0 = (long *)VELTS(ra0) + i0; + long *v1 = (long *)VELTS(ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) return 0; + return 1; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *v0 = (float *)VELTS(ra0) + i0; + float *v1 = (float *)VELTS(ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) return 0; + return 1; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *v0 = (double *)VELTS(ra0) + i0; + double *v1 = (double *)VELTS(ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) return 0; + return 1; + } + case tc7_cvect: { + double (*v0)[2]= (double (*)[2])VELTS(ra0) + i0; + double (*v1)[2] = (double (*)[2])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 /* FLOATS */ + } +} +static int raeql(ra0, as_equal, ra1) + SCM ra0, as_equal, ra1; +{ + SCM v0 = ra0, v1 = ra1; + array_dim dim0, dim1; + array_dim *s0 = &dim0, *s1 = &dim1; + sizet bas0 = 0, bas1 = 0; + int k, unroll = 1, ndim = 1; + if ARRAYP(ra0) { + ndim = ARRAY_NDIM(ra0); + s0 = ARRAY_DIMS(ra0); + bas0 = ARRAY_BASE(ra0); + v0 = ARRAY_V(ra0); + } + else { + s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1; + } + if ARRAYP(ra1) { + if (ndim != ARRAY_NDIM(ra1)) return 0; + s1 = ARRAY_DIMS(ra1); + bas1 = ARRAY_BASE(ra1); + v1 = ARRAY_V(ra1); + } + else { + if (1 != ndim) return BOOL_F; + s1->inc = 1; s1->lbnd = 0; s1->ubnd = LENGTH(v1) - 1; + } + if (TYP7(v0) != TYP7(v1)) return 0; + unroll = (bas0==bas1); + 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); + } + if (unroll && v0==v1) return BOOL_T; + return ramapc(raeql_1, as_equal, ra0, cons(ra1, EOL), ""); +} + +SCM raequal(ra0, ra1) + SCM ra0, ra1; +{ + return (raeql(ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F); +} +static char s_array_equalp[] = "array-equal?"; +SCM array_equal(ra0, ra1) + SCM ra0, ra1; +{ + if (IMP(ra0) || IMP(ra1)) + callequal: return equal(ra0, ra1); + switch TYP7(ra0) { + default: goto callequal; + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + break; + case tc7_smob: if (!ARRAYP(ra0)) goto callequal; + } + switch TYP7(ra1) { + default: goto callequal; + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + break; + case tc7_smob: if (!ARRAYP(ra1)) goto callequal; + } + return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F); +} + +static iproc subr2os[] = { + {s_ura_rd, ura_read}, + {s_ura_wr, ura_write}, + {0, 0}}; + +static iproc subr2s[] = { + {s_array_fill, array_fill}, + {s_array_copy, array_copy}, + {s_sarray_copy, array_copy}, + {0, 0}}; + +static iproc lsubr2s[] = { + {s_sc2array, sc2array}, + {s_array_map, array_map}, + {s_sarray_map, array_map}, + {s_array_for_each, array_for_each}, + {s_array_imap, array_imap}, + {0, 0}}; + +static void init_raprocs(subra) + ra_iproc *subra; +{ + for(; subra->name; subra++) + subra->sproc = CDR(intern(subra->name, strlen(subra->name))); +} + +void init_ramap() +{ + init_raprocs(ra_rpsubrs); + init_raprocs(ra_asubrs); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(lsubr2s, tc7_lsubr_2); + make_subr(s_array_equalp, tc7_rpsubr, array_equal); + smobs[0x0ff & (tc16_array>>8)].equalp = raequal; + add_feature(s_array_for_each); +} diff --git a/record.c b/record.c new file mode 100644 index 0000000..40b224c --- /dev/null +++ b/record.c @@ -0,0 +1,349 @@ +/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "record.c" code for (R5RS) proposed "Record" user definable datatypes. + Author: Radey Shouman */ + +#include "scm.h" + +typedef struct { + SCM rtd; + SCM name; + SCM fields; +} rtd_type; + +typedef union { + struct { + SCM proc; + SCM rtd; + } pred; + struct { + SCM proc; + SCM rtd; + SCM index; + } acc; + struct { + SCM proc; + SCM rtd; + SCM recsize; + SCM indices; + } constr; +} rec_cclo; + +long tc16_record; + +/* Record-type-descriptor for record-type-descriptors */ +static SCM the_rtd_rtd; + +/* Record <= [rtd, ... elts ... ] */ +#define REC_RTD(x) (VELTS(x)[0]) +#define RECP(x) (tc16_record==TYP16(x)) +#define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x)) +#define RTD_NAME(x) (((rtd_type *)CDR(x))->name) +#define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields) +#define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd) + +#ifdef ARRAYS +# define MAKE_REC_INDS(n) make_uve((long)n, MAKINUM(1)) +# define REC_IND_REF(x, i) VELTS(x)[(i)] +# define REC_IND_SET(x, i, val) VELTS(x)[(i)] = (val) +#else +# define MAKE_REC_INDS(n) make_vector(MAKINUM(n), INUM0) +# define REC_IND_REF(x, i) INUM(VELTS(x)[(i)]) +# define REC_IND_SET(x, i, val) VELTS(x)[(i)] = MAKINUM(val) +#endif + +static char s_record[] = "record"; +static char s_recordp[] = "record?"; +SCM recordp(obj) + SCM obj; +{ + return (NIMP(obj) && RECP(obj) ? BOOL_T : BOOL_F); +} +static char s_rec_pred1[] = " record-predicate-procedure"; +SCM rec_pred1(cclo, obj) + SCM cclo, obj; +{ + if (NIMP(obj) && RECP(obj) && (REC_RTD(obj)==RCLO_RTD(cclo))) + return BOOL_T; + return BOOL_F; +} +static SCM f_rec_pred1; +static char s_rec_pred[] = "record-predicate"; +SCM rec_pred(rtd) + SCM rtd; +{ + SCM cclo = makcclo(f_rec_pred1, 2L); + ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_pred); + RCLO_RTD(cclo) = rtd; + return cclo; +} + +static char s_rec_rtd[] = "record-type-descriptor"; +SCM rec_rtd(rec) + SCM rec; +{ + if (IMP(rec) || !RECP(rec)) return BOOL_F; + return REC_RTD(rec); +} + +static SCM f_rec_constr1; +static char s_rec_constr[] = "record-constructor"; +SCM rec_constr(rtd, flds) + SCM rtd, flds; +{ + SCM flst, fld; + SCM cclo = makcclo(f_rec_constr1, (long)sizeof(rec_cclo)/sizeof(SCM)); + rec_cclo *ptr = (rec_cclo *)CDR(cclo); + sizet i, j; + ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr); + ptr->constr.rtd = rtd; + i = ilength(RTD_FIELDS(rtd)); + ptr->constr.recsize = MAKINUM(i); + if UNBNDP(flds) { + ptr->constr.indices = MAKE_REC_INDS(i); + while (i--) + REC_IND_SET(ptr->constr.indices, i, i+1); + } + else { + ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr); + ptr->constr.indices = MAKE_REC_INDS(ilength(flds)); + for(i = 0; NIMP(flds); i++, flds = CDR(flds)) { + fld = CAR(flds); + ASSERT(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr); + flst = RTD_FIELDS(rtd); + for (j = 0; ; j++, flst = CDR(flst)) { + if (fld==CAR(flst)) { + REC_IND_SET(ptr->constr.indices, i, j+1); + break; + } + ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr); + } + } + } + return cclo; +} +static char s_rec_constr1[] = " record-constructor-procedure"; +SCM rec_constr1(args) + SCM args; +{ + SCM cclo = CAR(args); + SCM rec, inds = (((rec_cclo *)CDR(cclo))->constr.indices); + sizet i = INUM(((rec_cclo *)CDR(cclo))->constr.recsize); + args = CDR(args); + NEWCELL(rec); + DEFER_INTS; + SETCHARS(rec, must_malloc((i+1L)*sizeof(SCM), s_record)); + SETNUMDIGS(rec, i+1L, tc16_record); + ALLOW_INTS; + while (i--) + VELTS(rec)[i+1] = UNSPECIFIED; + REC_RTD(rec) = RCLO_RTD(cclo); + for (i = 0; i < LENGTH(inds); i++, args = CDR(args)) { + ASSERT(NNULLP(args), UNDEFINED, WNA, s_rec_constr1); + VELTS(rec)[ REC_IND_REF(inds, i) ] = CAR(args); + } + ASSERT(NULLP(args), UNDEFINED, WNA, s_rec_constr1); + return rec; + +} + +/* Makes an accessor or modifier. + A cclo with 2 env elts -- rtd and field-number. */ +static SCM makrecclo(proc, rtd, field, what) + SCM proc, rtd, field; + char *what; +{ + SCM flst; + SCM cclo = makcclo(proc, 3L); + int i; + ASSERT(RTDP(rtd), rtd, ARG1, what); + ASSERT(NIMP(field) && SYMBOLP(field), field, ARG2, what); + RCLO_RTD(cclo) = rtd; + flst = RTD_FIELDS(rtd); + for (i = 1; ; i++) { + ASSERT(NNULLP(flst), field, ARG2, what); + if (CAR(flst)==field) break; + flst = CDR(flst); + } + (((rec_cclo *)CDR(cclo))->acc.index) = MAKINUM(i); + return cclo; +} +static char s_rec_accessor1[] = " record-accessor-procedure"; +SCM rec_accessor1(cclo, rec) + SCM cclo, rec; +{ + ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_accessor1); + ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_accessor1); + return VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ]; +} +static char s_rec_modifier1[] = " record-modifier-procedure"; +SCM rec_modifier1(cclo, rec, val) + SCM cclo, rec, val; +{ + ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_modifier1); + ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_modifier1); + VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ] = val; + return UNSPECIFIED; +} +static SCM f_rec_accessor1; +static char s_rec_accessor[] = "record-accessor"; +SCM rec_accessor(rtd, field) + SCM rtd, field; +{ + return makrecclo(f_rec_accessor1, rtd, field, s_rec_accessor); +} +static SCM f_rec_modifier1; +static char s_rec_modifier[] = "record-modifier"; +SCM rec_modifier(rtd, field) + SCM rtd, field; +{ + return makrecclo(f_rec_modifier1, rtd, field, s_rec_accessor); +} + +static char s_makrectyp[] = "make-record-type"; +SCM *loc_makrtd; +SCM makrectyp(name, fields) + SCM name, fields; +{ + SCM n; +#ifndef RECKLESS + if(ilength(fields) < 0) + errout: wta(fields, (char *)ARG2, s_makrectyp); + for (n=fields; NIMP(n); n = CDR(n)) + if (!SYMBOLP(CAR(n))) goto errout; +#endif + return apply(*loc_makrtd, name, cons(fields, listofnull)); +} + +static SCM markrec(ptr) + SCM ptr; +{ + sizet i; + if GC8MARKP(ptr) return BOOL_F; + SETGC8MARK(ptr); + for (i = NUMDIGS(ptr); --i;) + if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]); + return REC_RTD(ptr); +} +static sizet freerec(ptr) + CELLPTR ptr; +{ + must_free(CHARS(ptr)); + return sizeof(SCM)*NUMDIGS(ptr); +} +static int recprin1(exp, port, writing) + SCM exp, port; + int writing; +{ + SCM names = RTD_FIELDS(REC_RTD(exp)); + sizet i; + lputs("#s(", port); + iprin1(RTD_NAME(REC_RTD(exp)), port, 0); + for (i = 1; i < NUMDIGS(exp); i++) { + lputc(' ', port); + iprin1(CAR(names), port, 0); + names = CDR(names); + lputc(' ', port); + iprin1(VELTS(exp)[i], port, writing); + } + lputc(')', port); +/* + lputs("#<record <", port); + iprin1(RTD_NAME(REC_RTD(exp)), port, 0); + lputc('>', port); + for(i = 1; i < NUMDIGS(exp); i++) { + lputc(' ', port); + iprin1(VELTS(exp)[i], port, writing); + } + lputc('>', port); +*/ + return 1; +} +SCM recequal(rec0, rec1) + SCM rec0, rec1; +{ + sizet i = NUMDIGS(rec0); + if (i != NUMDIGS(rec1)) return BOOL_F; + if (REC_RTD(rec0) != REC_RTD(rec1)) return BOOL_F; + while(--i) + if FALSEP(equal(VELTS(rec0)[i], VELTS(rec1)[i])) + return BOOL_F; + return BOOL_T; +} +static smobfuns recsmob = {markrec, freerec, recprin1, recequal}; +static iproc subr1s[] = { + {s_recordp, recordp}, + {s_rec_pred, rec_pred}, + {s_rec_rtd, rec_rtd}, + {0, 0}}; +static iproc subr2s[] = { + {s_rec_accessor, rec_accessor}, + {s_rec_modifier, rec_modifier}, + {s_makrectyp, makrectyp}, + {0, 0}}; +static char s_name[] = "name"; +static char s_fields[] = "fields"; +void init_record() +{ + SCM i_name = CAR(intern(s_name, (sizeof s_name)-1)); + SCM i_fields = CAR(intern(s_fields, (sizeof s_fields)-1)); + tc16_record = newsmob(&recsmob); + NEWCELL(the_rtd_rtd); + SETCHARS(the_rtd_rtd, must_malloc((long)sizeof(rtd_type), s_record)); + SETNUMDIGS(the_rtd_rtd, (long)sizeof(rtd_type)/sizeof(SCM), tc16_record); + REC_RTD(the_rtd_rtd) = the_rtd_rtd; + RTD_NAME(the_rtd_rtd) = makfromstr(s_record, (sizeof s_record)-1); + RTD_FIELDS(the_rtd_rtd) = cons2(i_name, i_fields, EOL); + sysintern("record:rtd", the_rtd_rtd); + f_rec_pred1 = make_subr(s_rec_pred1, tc7_subr_2, rec_pred1); + f_rec_constr1 = make_subr(s_rec_constr1, tc7_lsubr, rec_constr1); + f_rec_accessor1 = make_subr(s_rec_accessor1, tc7_subr_2, rec_accessor1); + f_rec_modifier1 = make_subr(s_rec_modifier1, tc7_subr_3, rec_modifier1); + make_subr(s_rec_constr, tc7_subr_2o, rec_constr); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); + sysintern("record-type-descriptor?", rec_pred(the_rtd_rtd)); + sysintern("record-type-name", rec_accessor(the_rtd_rtd, i_name)); + sysintern("record-type-field-names", rec_accessor(the_rtd_rtd, i_fields)); + loc_makrtd = &CDR(sysintern("RTD:make", rec_constr(the_rtd_rtd, UNDEFINED))); + add_feature(s_record); +} @@ -0,0 +1,1649 @@ +/* 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. + */ + +/* "repl.c" error, read-eval-print loop, read, write and load code. + Author: Aubrey Jaffer */ + +#include "scm.h" +#include "setjump.h" +void igc P((char *what, STACKITEM *stackbase)); + +#ifdef ARM_ULIB +# include <termio.h> +int set_erase() +{ + struct termio tin; + + ioctl(0, TCGETA, &tin); + tin.c_cc[VERASE] = '\010'; + + ioctl(0, TCSETA,&tin); + return(0); +} +#endif + +unsigned char upcase[CHAR_CODE_LIMIT]; +unsigned char downcase[CHAR_CODE_LIMIT]; +unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz"; +unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; +extern int verbose; +void init_tables() +{ + int i; + for(i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i; + for(i = 0;i<sizeof lowers/sizeof(char);i++) { + upcase[lowers[i]] = uppers[i]; + downcase[uppers[i]] = lowers[i]; + } + verbose = 1; /* Here so that monitor info won't be */ + /* printed while in init_storage. (BOOM) */ +} + +#ifdef EBCDIC +char *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", s_newline, "tab", "backspace", "return", "page", "null"}; +char 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 *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", s_newline, "tab", "backspace", "return", "page", "null", "del"}; +char 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 */ +char *isymnames[] = { + /* Special Forms */ + /* NUM_ISPCSYMS ISPCSYMS here */ + "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda", + "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!", + "#@define", "#@apply", "#@call-with-current-continuation", + /* user visible ISYMS */ + /* other keywords */ + /* Flags */ + "#f", "#t", "#<undefined>", "#<eof>", "()", "#<unspecified>" + }; + +static char s_read_char[] = "read-char", s_peek_char[] = "peek-char"; +char s_read[] = "read", s_write[] = "write", s_newline[] = "newline"; +static char s_display[] = "display", s_write_char[] = "write-char"; + +static char s_eofin[] = "end of file in "; +static char s_unknown_sharp[] = "unknown # object"; + +static SCM lreadr P((SCM tok_buf, SCM port)); +static SCM lreadparen P((SCM tok_buf, SCM port, char *name)); +static sizet read_token P((int ic, SCM tok_buf, SCM port)); + +void intprint(n, radix, port) + long n; + int radix; + SCM port; +{ + char num_buf[INTBUFLEN]; + lfwrite(num_buf, (sizet)sizeof(char), iint2str(n, radix, num_buf), port); +} + +void ipruk(hdr, ptr, port) + char *hdr; + SCM ptr; + SCM port; +{ + lputs("#<unknown-", port); + lputs(hdr, port); + if CELLP(ptr) { + lputs(" (0x", port); + intprint(CAR(ptr), 16, port); + lputs(" . 0x", port); + intprint(CDR(ptr), 16, port); + lputs(") @", port); + } + lputs(" 0x", port); + intprint(ptr, 16, port); + lputc('>', port); +} + +void iprlist(hdr, exp, tlr, port, writing) + char *hdr, tlr; + SCM exp; + SCM port; + int writing; +{ + lputs(hdr, port); + /* CHECK_INTS; */ + iprin1(CAR(exp), port, writing); + exp = CDR(exp); + for(;NIMP(exp);exp = CDR(exp)) { + if NECONSP(exp) break; + lputc(' ', port); + /* CHECK_INTS; */ + iprin1(CAR(exp), port, writing); + } + if NNULLP(exp) { + lputs(" . ", port); + iprin1(exp, port, writing); + } + lputc(tlr, port); +} +void iprin1(exp, port, writing) + SCM exp; + SCM port; +int writing; +{ + register long i; +taloop: + switch (7 & (int)exp) { + case 2: + case 6: + intprint(INUM(exp), 10, port); + break; + case 4: + if ICHRP(exp) { + i = ICHR(exp); + if (writing) lputs("#\\", port); + if (!writing) lputc((int)i, port); + else if ((i <= ' ') && charnames[i]) lputs(charnames[i], port); +#ifndef EBCDIC + else if (i=='\177') + lputs(charnames[(sizeof charnames/sizeof(char *))-1], port); +#endif /* ndef EBCDIC */ + else if (i > '\177') + intprint(i, 8, port); + else lputc((int)i, port); + } + else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *)))) + lputs(ISYMCHARS(exp), port); + else if ILOCP(exp) { + lputs("#@", port); + intprint((long)IFRAME(exp), 10, port); + lputc(ICDRP(exp)?'-':'+', port); + intprint((long)IDIST(exp), 10, port); + } + else goto idef; + break; + case 1: /* gloc */ + lputs("#@", port); + exp = CAR(exp-1); + goto taloop; + default: + idef: + ipruk("immediate", exp, port); + break; + case 0: + switch TYP7(exp) { + case tcs_cons_gloc: + case tcs_cons_imcar: + case tcs_cons_nimcar: + iprlist("(", exp, ')', port, writing); + break; + case tcs_closures: + exp = CODE(exp); + iprlist("#<CLOSURE ", exp, '>', port, writing); + break; + case tc7_string: + if (writing) { + lputc('\"', port); + for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) { + case '"': + case '\\': + lputc('\\', port); + default: + lputc(CHARS(exp)[i], port); + } + lputc('\"', port); + break; + } + case tcs_symbols: + lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port); + break; + case tc7_vector: + lputs("#(", port); + for(i = 0;i+1<LENGTH(exp);++i) { + /* CHECK_INTS; */ + iprin1(VELTS(exp)[i], port, writing); + lputc(' ', port); + } + if (i<LENGTH(exp)) { + /* CHECK_INTS; */ + iprin1(VELTS(exp)[i], port, writing); + } + lputc(')', port); + break; + case tc7_bvect: + case tc7_ivect: + case tc7_uvect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + raprin1(exp, port, writing); + break; + case tcs_subrs: + lputs("#<primitive-procedure ", port); + lputs(CHARS(SNAME(exp)), port); + lputc('>', port); + break; +#ifdef CCLO + case tc7_cclo: + lputs("#<compiled-closure ", port); + iprin1(CCLO_SUBR(exp), port, writing); + lputc('>', port); + break; +#endif + case tc7_contin: + lputs("#<continuation ", port); + intprint(LENGTH(exp), 10, port); + lputs(" @ ", port); + intprint((long)CHARS(exp), 16, port); + lputc('>', port); + break; + case tc7_port: + i = PTOBNUM(exp); + if (i<numptob && ptobs[i].print && (ptobs[i].print)(exp, port, writing)) + break; + goto punk; + case tc7_smob: + i = SMOBNUM(exp); + if (i<numsmob && smobs[i].print && (smobs[i].print)(exp, port, writing)) + break; + goto punk; + default: punk: ipruk("type", exp, port); + } + } +} + +#ifdef __IBMC__ +# define MSDOS +#endif +#ifdef MSDOS +# ifndef GO32 +# include <io.h> +# include <conio.h> +static int input_waiting(f) + FILE *f; +{ + 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 + +# ifdef HAVE_SELECT +# ifdef HAVE_SYS_TIME_H +# include <sys/time.h> +# endif +# endif + +static int input_waiting(f) + FILE *f; +{ +# ifdef HAVE_SELECT + fd_set ifds; + struct timeval tv; + + FD_ZERO(&ifds); + FD_SET(fileno(f), &ifds); + tv.tv_sec = 0; + tv.tv_usec = 0; + select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv); + return FD_ISSET(fileno(f), &ifds); +# else +# ifdef FIONREAD + long remir; + if (feof(f)) return 1; + ioctl(fileno(f), FIONREAD, &remir); + return remir; +# else + return -1; +# endif +# endif +} +#endif +/* perhaps should undefine MSDOS from __IBMC__ here */ +#ifndef GO32 +static char s_char_readyp[]="char-ready?"; +SCM char_readyp(port) + SCM port; +{ + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp); + if (CRDYP(port) || !(BUF0 & CAR(port))) return BOOL_T; + return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F; +} +#endif + +SCM eof_objectp(x) + SCM x; +{ + return (EOF_VAL==x) ? BOOL_T : BOOL_F; +} + +void lfflush(port) /* internal SCM call */ + SCM port; +{ + sizet i = PTOBNUM(port); + (ptobs[i].fflush)(STREAM(port)); +} +static char s_flush[] = "force-output"; +SCM lflush(port) /* user accessible as force-output */ + SCM port; +{ + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush); + { + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fflush)(STREAM(port));); + return UNSPECIFIED; + } +} + +SCM lwrite(obj, port) + SCM obj, port; +{ + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write); + iprin1(obj, port, 1); +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) close_port(port); +# endif +#endif + return UNSPECIFIED; +} +SCM display(obj, port) + SCM obj, port; +{ + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display); + iprin1(obj, port, 0); +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) close_port(port); +# endif +#endif + return UNSPECIFIED; +} +SCM newline(port) + SCM port; +{ + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline); + lputc('\n', port); +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) close_port(port); + else +# endif +#endif + if (port==cur_outp) lfflush(port); + return UNSPECIFIED; +} +SCM write_char(chr, port) + SCM chr, port; +{ + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char); + ASSERT(ICHRP(chr), chr, ARG1, s_write_char); + lputc((int)ICHR(chr), port); +#ifdef HAVE_PIPE +# ifdef EPIPE + if (EPIPE==errno) close_port(port); +# endif +#endif + return UNSPECIFIED; +} + +FILE *trans = 0; +SCM trans_on(fil) + SCM fil; +{ + transcript = open_file(fil, makfromstr("w", (sizet)sizeof(char))); + if FALSEP(transcript) trans = 0; + else trans = STREAM(transcript); + return UNSPECIFIED; +} +SCM trans_off() +{ + if (!FALSEP(transcript)) close_port(transcript); + transcript = BOOL_F; + trans = 0; + return UNSPECIFIED; +} + +void lputc(c, port) + int c; + SCM port; +{ + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fputc)(c, STREAM(port));); + if (trans && (port==def_outp || port==cur_errp)) + SYSCALL(fputc(c, trans);); +} +void lputs(s, port) + char *s; + SCM port; +{ + sizet i = PTOBNUM(port); + SYSCALL((ptobs[i].fputs)(s, STREAM(port));); + if (trans && (port==def_outp || port==cur_errp)) + SYSCALL(fputs(s, trans);); +} +int lfwrite(ptr, size, nitems, port) + char *ptr; + sizet size; + sizet nitems; + SCM port; +{ + int ret; + sizet i = PTOBNUM(port); + SYSCALL(ret = (ptobs[i].fwrite) + (ptr, size, nitems, STREAM(port));); + if (trans && (port==def_outp || port==cur_errp)) + SYSCALL(fwrite(ptr, size, nitems, trans);); + return ret; +} + +int lgetc(port) + SCM port; +{ + FILE *f; + int c; + sizet i; + /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */ + if CRDYP(port) + { + c = CGETUN(port); + CLRDY(port); /* Clear ungetted char */ + return c; + } + f=STREAM(port); + i = PTOBNUM(port); +#ifdef linux + c = (ptobs[i].fgetc)(f); +#else + SYSCALL(c = (ptobs[i].fgetc)(f);); +#endif + if (trans && (f==stdin)) SYSCALL(fputc(c, trans);); + return c; +} +void lungetc(c, port) + int c; + SCM port; +{ +/* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/ + CUNGET(c, port); +} + +SCM scm_read_char(port) + SCM port; +{ + int c; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + return MAKICHR(c); +} +SCM peek_char(port) + SCM port; +{ + int c; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char); + c = lgetc(port); + if (EOF==c) return EOF_VAL; + lungetc(c, port); + return MAKICHR(c); +} + +char *grow_tok_buf(tok_buf) + SCM tok_buf; +{ + sizet len = LENGTH(tok_buf); + len += len / 2; + resizuve(tok_buf, (SCM)MAKINUM(len)); + return CHARS(tok_buf); +} + +static int flush_ws(port, eoferr) + SCM port; +char *eoferr; +{ + register int c; + while(1) switch (c = lgetc(port)) { + case EOF: +goteof: + if (eoferr) wta(UNDEFINED, s_eofin, eoferr); + return c; + case ';': +lp: + switch (c = lgetc(port)) { + case EOF: + goto goteof; + default: + goto lp; + case LINE_INCREMENTORS: + break; + } + case LINE_INCREMENTORS: + if (port==loadport) linum++; + case WHITE_SPACES: + break; + default: + return c; + } +} +SCM lread(port) + SCM port; +{ + int c; + SCM tok_buf; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read); + do { + c = flush_ws(port, (char *)NULL); + if (EOF==c) return EOF_VAL; + lungetc(c, port); + tok_buf = makstr(30L); + } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port))); + return tok_buf; +} +static SCM lreadr(tok_buf, port) + SCM tok_buf; +SCM port; +{ + int c; + sizet j; + SCM p; +tryagain: + c = flush_ws(port, s_read); + switch (c) { +/* case EOF: return EOF_VAL;*/ +#ifdef BRACKETS_AS_PARENS + case '[': +#endif + case '(': return lreadparen(tok_buf, port, s_list); +#ifdef BRACKETS_AS_PARENS + case ']': +#endif + case ')': warn("unexpected \")\"", ""); + goto tryagain; + case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL); + case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL); + case ',': + c = lgetc(port); + if ('@'==c) p = i_uq_splicing; + else { + lungetc(c, port); + p = i_unquote; + } + return cons2(p, lreadr(tok_buf, port), EOL); + case '#': + c = lgetc(port); + switch (c) { +#ifdef BRACKETS_AS_PARENS + case '[': +#endif + case '(': + p = lreadparen(tok_buf, port, s_vector); + return NULLP(p) ? nullvect : vector(p); + case 't': case 'T': return BOOL_T; + case 'f': case 'F': return 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': + lungetc(c, port); + c = '#'; + goto num; + case '*': + j = read_token(c, tok_buf, port); + p = istr2bve(CHARS(tok_buf)+1, (long)(j-1)); + if (NFALSEP(p)) return p; + else goto unkshrp; + case '\\': + c = lgetc(port); + j = read_token(c, tok_buf, port); + if (j==1) return MAKICHR(c); + if (c >= '0' && c < '8') { + p = istr2int(CHARS(tok_buf), (long)j, 8); + if (NFALSEP(p)) return MAKICHR(INUM(p)); + } + for (c = 0;c<sizeof charnames/sizeof(char *);c++) + if (charnames[c] + && (0==strcmp(charnames[c], CHARS(tok_buf)))) + return MAKICHR(charnums[c]); + wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf)); + case '|': + j = 1; /* here j is the comment nesting depth */ +lp: c = lgetc(port); +lpc: switch (c) { + case EOF: + wta(UNDEFINED, s_eofin, "balanced comment"); + case LINE_INCREMENTORS: + if (port==loadport) linum++; + default: + goto lp; + case '|': + if ('#' != (c = lgetc(port))) goto lpc; + if (--j) goto lp; + break; + case '#': + if ('|' != (c = lgetc(port))) goto lpc; + ++j; goto lp; + } + goto tryagain; + case '.': + p = lreadr(tok_buf, port); + return EVAL(p, (SCM)EOL); + default: callshrp: + p = CDR(intern("read:sharp", (sizeof "read:sharp")-1)); + if NIMP(p) { + p = apply(p, MAKICHR(c), acons(port, EOL, EOL)); + if (UNSPECIFIED==p) goto tryagain; + return p; + } + unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, ""); + } + case '\"': + j = 0; + while ('\"' != (c = lgetc(port))) { + ASSERT(EOF != c, UNDEFINED, s_eofin, s_string); + if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf); + if (c=='\\') switch (c = lgetc(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; + } + CHARS(tok_buf)[j] = c; + ++j; + } + if (j==0) return nullstr; + CHARS(tok_buf)[j] = 0; + return makfromstr(CHARS(tok_buf), j); + case DIGITS: + case '.': case '-': case '+': +num: + j = read_token(c, tok_buf, port); + p = istring2number(CHARS(tok_buf), (long)j, 10L); + if NFALSEP(p) return p; + if (c=='#') { + if ((j==2) && (lgetc(port)=='(')) { + lungetc('(', port); + c = CHARS(tok_buf)[1]; + goto callshrp; + } + wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf)); + } + goto tok; + default: + j = read_token(c, tok_buf, port); +tok: + p = intern(CHARS(tok_buf), j); + return CAR(p); + } +} + +#ifdef _UNICOS +_Pragma("noopt"); /* # pragma _CRI noopt */ +#endif +static sizet read_token(ic, tok_buf, port) + int ic; + SCM tok_buf; + SCM port; +{ + register sizet j = 1; + register int c = ic; + register char *p = CHARS(tok_buf); + p[0] = downcase[c]; + while(1) { + if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf); + switch (c = lgetc(port)) { +#ifdef BRACKETS_AS_PARENS + case '[': case ']': +#endif + case '(': case ')': case '\"': case ';': + case ',': case '`': case '#': + case WHITE_SPACES: + case LINE_INCREMENTORS: + lungetc(c, port); + case EOF: + p[j] = 0; + return j; + default: + p[j++] = downcase[c]; + } + } +} +#ifdef _UNICOS +_Pragma("opt"); /* # pragma _CRI opt */ +#endif + +static SCM lreadparen(tok_buf, port, name) + SCM tok_buf; + SCM port; + char *name; +{ + SCM tmp, tl, ans; + int c = flush_ws(port, name); + if (')'==c +#ifdef BRACKETS_AS_PARENS + || ']'==c +#endif + ) return EOL; + lungetc(c, port); + if (i_dot==(tmp = lreadr(tok_buf, port))) { + ans = lreadr(tok_buf, port); + closeit: + if (')' != (c = flush_ws(port, name)) +#ifdef BRACKETS_AS_PARENS + && ']' != c +#endif + ) + wta(UNDEFINED, "missing close paren", ""); + return ans; + } + ans = tl = cons(tmp, EOL); + while (')' != (c = flush_ws(port, name)) +#ifdef BRACKETS_AS_PARENS + && ']' != c +#endif + ) { + lungetc(c, port); + if (i_dot==(tmp = lreadr(tok_buf, port))) { + CDR(tl) = lreadr(tok_buf, port); + goto closeit; + } + tl = (CDR(tl) = cons(tmp, EOL)); + } + return ans; +} + +/* These procedures implement synchronization primitives. Processors + with an atomic test-and-set instruction can use it here (and not + DEFER_INTS). */ +char s_tryarb[] = "try-arbiter"; +char s_relarb[] = "release-arbiter"; +long tc16_arbiter; +SCM tryarb(arb) + SCM arb; +{ + ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb); + DEFER_INTS; + if (CAR(arb) & (1L<<16)) + arb = BOOL_F; + else { + CAR(arb) = tc16_arbiter | (1L<<16); + arb = BOOL_T; + } + ALLOW_INTS; + return arb; +} +SCM relarb(arb) + SCM arb; +{ + ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb); + if (!(CAR(arb) & (1L<<16))) return BOOL_F; + CAR(arb) = tc16_arbiter; + return BOOL_T; +} +SCM makarb(name) + SCM name; +{ + register SCM z; + NEWCELL(z); + CDR(z) = name; + CAR(z) = tc16_arbiter; + return z; +} +static int prinarb(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#<arbiter ", port); + if (CAR(exp) & (1L<<16)) lputs("locked ", port); + iprin1(CDR(exp), port, writing); + lputc('>', port); + return !0; +} + +static char s_tryload[] = "try-load"; +#define s_load (&s_tryload[4]) + +struct errdesc {char *msg;char *s_response;short parent_err;}; +struct errdesc errmsgs[] = { + {"Wrong number of args", 0, 0}, + {"numerical overflow", 0, FPE_SIGNAL}, + {"Argument out of range", 0, FPE_SIGNAL}, + {"Could not allocate", "out-of-storage", 0}, + {"EXIT", "end-of-program", -1}, + {"hang up", "hang-up", EXIT}, + {"user interrupt", "user-interrupt", 0}, + {"arithmetic error", "arithmetic-error", 0}, + {"bus error", 0, 0}, + {"segment violation", 0, 0}, + {"alarm", "alarm-interrupt", 0} +}; + +int errjmp_bad = 1, ints_disabled = 1, sig_deferred = 0, alrm_deferred; +SCM err_exp, err_env; +char *err_pos, *err_s_subr; +cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL}; +cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL}; +SCM *loc_errobj = (SCM *)&tmp_errobj; +SCM *loc_loadpath = (SCM *)&tmp_loadpath; +SCM loadport = UNDEFINED; +long linum = 1; +int verbose = 1; +long cells_allocated = 0, lcells_allocated = 0, + mallocated = 0, lmallocated = 0, + rt = 0, gc_rt, gc_time_taken; +long gc_cells_collected, gc_malloc_collected, gc_ports_collected; +long gc_syms_collected; +static void def_err_response P((void)); + +int handle_it(i) + int i; +{ + char *name = errmsgs[i-WNA].s_response; + SCM proc; + if (errjmp_bad) return -1; /* sends it to def_err_response */ + if (name) { + NEWCELL(proc); /* discard possibly-used cell */ + proc = CDR(intern(name, (sizet)strlen(name))); + if NIMP(proc) { + apply(proc, EOL, EOL); + return i; + } + } + return errmsgs[i-WNA].parent_err; +} +static char s_eval_string[] = "eval-string"; +static char s_load_string[] = "load-string"; +SCM scm_eval_string(str) + SCM str; +{ + str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string); + str = lread(str); + return EVAL(str, (SCM)EOL); +} +SCM scm_load_string(str) + SCM str; +{ + ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, + s_load_string); + str = mkstrport(INUM0, str, OPN | RDNG, s_load_string); + while(1) { + SCM form = lread(str); + if (EOF_VAL==form) break; + SIDEVAL(form, EOL); + } + return BOOL_T; +} + +SCM exitval; /* INUM with return value */ +extern char s_unexec[]; +SCM repl_driver(initpath) + char *initpath; +{ +#ifdef _UNICOS + int i; +#else + long i; +#endif + CONT(rootcont)->stkbse = (STACKITEM *)&i; + i = setjmp(CONT(rootcont)->jmpbuf); +#ifndef SHORT_INT + if (i) i = UNCOOK(i); +#endif + /* printf("repl_driver got %d\n", i); */ + drloop: + switch ((int)i) { + default: { + char *name = errmsgs[i-WNA].s_response; + if (name) { + SCM proc = CDR(intern(name, (sizet)strlen(name))); + if NIMP(proc) apply(proc, EOL, EOL); + } + if ((i = errmsgs[i-WNA].parent_err)) goto drloop; + def_err_response(); + goto reset_toplvl; + } + case 0: + exitval = MAKINUM(EXIT_SUCCESS); + errjmp_bad = 0; + errno = 0; + alrm_deferred = 0; + sig_deferred = 0; + ints_disabled = 0; + if (dumped) { + lcells_allocated = cells_allocated; + lmallocated = mallocated; + rt = INUM(my_time()); + gc_time_taken = 0; + } + else if (scm_ldfile(initpath)) /* load Scheme init files */ + wta(*loc_errobj, "Could not open file", s_load); + scm_evstr("(boot-tail)"); /* initialization tail-call */ + case -2: /* abrt */ + reset_toplvl: + errjmp_bad = 0; + alrm_deferred = 0; + sig_deferred = 0; + ints_disabled = 0; + + /* Closing the loading file turned out to be a bad idea. */ + /* But I will leave the code here in case someone wants it. */ +#ifdef CLOSE_LOADING_PORTS_ON_ABORT + if (NIMP(loadport) && OPINPORTP(loadport)) { + if (verbose > 1) { + lputs("; Aborting load (closing): ", cur_errp); + display(*loc_loadpath, cur_errp); + newline(cur_errp); + } + close_port(loadport); /* close loading file. */ + } +#endif + *loc_loadpath = BOOL_F; + loadport = UNDEFINED; + repl(); + err_pos = (char *)EXIT; + i = EXIT; + goto drloop; /* encountered EOF on stdin */ + case -1: /* quit */ + return exitval; + case -3: /* restart. */ + return 0; +#ifdef CAN_DUMP + case -4: /* dump */ + igc(s_unexec, (STACKITEM *)0); + dumped = 1; + unexec(CHARS(*loc_errobj), execpath, 0, 0, 0); + goto reset_toplvl; +#endif + } +} + +SCM line_num() +{ + return MAKINUM(linum); +} +SCM prog_args() +{ + return progargs; +} + +extern char s_heap[]; +extern sizet hplim_ind; +extern CELLPTR *hplims; +void growth_mon(obj, size, units) + char *obj; + long size; + char *units; +{ + if (verbose>2) + { + lputs("; grew ", cur_errp); + lputs(obj, cur_errp); + lputs(" to ", cur_errp); + intprint(size, 10, cur_errp); + lputc(' ', cur_errp); + lputs(units, cur_errp); + if ((verbose>4) && (obj==s_heap)) heap_report(); + lputs("\n", cur_errp); + } +} + +void gc_start(what) + char *what; +{ + if (verbose>3 && FPORTP(cur_errp)) { + ALLOW_INTS; + lputs(";GC(", cur_errp); + lputs(what, cur_errp); + lputs(")", cur_errp); + lfflush(cur_errp); + DEFER_INTS; + } + gc_rt = INUM(my_time()); + gc_cells_collected = 0; + gc_malloc_collected = 0; + gc_ports_collected = 0; + gc_syms_collected = 0; +} +void gc_end() +{ + gc_rt = INUM(my_time()) - gc_rt; + gc_time_taken = gc_time_taken + gc_rt; + if (verbose>3) { + ALLOW_INTS; + if (!FPORTP(cur_errp)) lputs(";GC ", cur_errp); + intprint(time_in_msec(gc_rt), 10, cur_errp); + lputs(" cpu mSec, ", cur_errp); + intprint(gc_cells_collected, 10, cur_errp); + lputs(" cells, ", cur_errp); + intprint(gc_malloc_collected, 10, cur_errp); + lputs(" malloc, ", cur_errp); + intprint(gc_syms_collected, 10, cur_errp); + lputs(" syms, ", cur_errp); + intprint(gc_ports_collected, 10, cur_errp); + lputs(" ports collected\n", cur_errp); + lfflush(cur_errp); + DEFER_INTS; + } +} +void repl_report() +{ + if (verbose>1) { + lfflush(cur_outp); + lputs(";Evaluation took ", cur_errp); + intprint(time_in_msec(INUM(my_time())-rt), 10, cur_errp); + lputs(" mSec (", cur_errp); + intprint(time_in_msec(gc_time_taken), 10, cur_errp); + lputs(" in gc) ", cur_errp); + intprint(cells_allocated - lcells_allocated, 10, cur_errp); + lputs(" cells work, ", cur_errp); + intprint(mallocated - lmallocated, 10, cur_errp); + lputs(" bytes other\n", cur_errp); + lfflush(cur_errp); + } +} +SCM lroom(args) + SCM args; +{ + intprint(cells_allocated, 10, cur_errp); + lputs(" out of ", cur_errp); + intprint(heap_size, 10, cur_errp); + lputs(" cells in use, ", cur_errp); + intprint(mallocated, 10, cur_errp); + lputs(" bytes allocated (of ", cur_errp); + intprint(mtrigger, 10, cur_errp); + lputs(")\n", cur_errp); + if NIMP(args) { + heap_report(); + lputs("\n", cur_errp); + stack_report(); + } + return UNSPECIFIED; +} +void heap_report() +{ + sizet i = 0; + lputs("; heap segments:", cur_errp); + while(i<hplim_ind) { + lputs("\n; 0x", cur_errp); + intprint((long)hplims[i++], 16, cur_errp); + lputs(" - 0x", cur_errp); + intprint((long)hplims[i++], 16, cur_errp); + } +} +void exit_report() +{ + if (verbose>2) { + lputs(";Totals: ", cur_errp); + intprint(time_in_msec(INUM(my_time())), 10, cur_errp); + lputs(" mSec my time, ", cur_errp); + intprint(time_in_msec(INUM(your_time())), 10, cur_errp); + lputs(" mSec your time\n", cur_errp); + } +} + +SCM prolixity(arg) + SCM arg; +{ + int old = verbose; + if (!UNBNDP(arg)) { + if FALSEP(arg) verbose = 1; + else verbose = INUM(arg); + } + return MAKINUM(old); +} + +void repl() +{ + SCM x; + repl_report(); + while(1) { + if OPOUTPORTP(cur_inp) { /* This case for curses window */ + lfflush(cur_outp); + if (verbose) lputs(PROMPT, cur_inp); + lfflush(cur_inp); + } + else { + if (verbose) lputs(PROMPT, cur_outp); + lfflush(cur_outp); + } + lcells_allocated = cells_allocated; + lmallocated = mallocated; + x = lread(cur_inp); + rt = INUM(my_time()); + gc_time_taken = 0; + if (EOF_VAL==x) break; + if (!CRDYP(cur_inp)) /* assure newline read (and transcripted) */ + lungetc(lgetc(cur_inp), cur_inp); +#ifdef __TURBOC__ + if ('\n' != CGETUN(cur_inp)) + if OPOUTPORTP(cur_inp) /* This case for curses window */ + {lfflush(cur_outp); newline(cur_inp);} + else newline(cur_outp); +#endif + x = EVAL(x, (SCM)EOL); + repl_report(); + iprin1(x, cur_outp, 1); + lputc('\n', cur_outp); + } +} +SCM quit(n) + SCM n; +{ + if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS); + else if INUMP(n) exitval = n; + else exitval = MAKINUM(EXIT_FAILURE); + if (errjmp_bad) exit(INUM(exitval)); + dowinds(EOL, ilength(dynwinds)); + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-1)); +} +SCM abrt() +{ + if (errjmp_bad) exit(INUM(exitval)); + dowinds(EOL, ilength(dynwinds)); +#ifdef CAUTIOUS + stacktrace = EOL; +#endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-2)); +} +char s_restart[] = "restart"; +SCM restart() +{ + /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */ + dowinds(EOL, ilength(dynwinds)); +#ifdef CAUTIOUS + stacktrace = EOL; +#endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-3)); +} + +#ifdef CAN_DUMP +char s_unexec[] = "unexec"; +SCM scm_unexec(newpath) + SCM newpath; +{ + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec); + *loc_errobj = newpath; +# ifdef CAUTIOUS + stacktrace = EOL; +# endif + longjmp(CONT(rootcont)->jmpbuf, COOKIE(-4)); +} +#endif + +char s_execpath[] = "execpath"; +SCM scm_execpath(newpath) + SCM newpath; +{ + SCM retval = execpath ? makfrom0str(execpath) : BOOL_F; + if (UNBNDP(newpath)) + return retval; + if (FALSEP(newpath)) { + if (execpath) free(execpath); + execpath = 0; + return retval; + } + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath); + if (execpath) free(execpath); + execpath = scm_cat_path(0L, CHARS(newpath), 0L); + return retval; +} + +void han_sig() +{ + sig_deferred = 0; + if (INT_SIGNAL != handle_it(INT_SIGNAL)) + wta(UNDEFINED, (char *)INT_SIGNAL, ""); +} +void han_alrm() +{ + alrm_deferred = 0; + if (ALRM_SIGNAL != handle_it(ALRM_SIGNAL)) + wta(UNDEFINED, (char *)ALRM_SIGNAL, ""); +} + +SCM tryload(filename) + SCM filename; +{ + ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load); + { + SCM oloadpath = *loc_loadpath; + SCM oloadport = loadport; + long olninum = linum; + SCM port, newform = BOOL_F; + port = open_file(filename, makfromstr("r", (sizet)sizeof(char))); + if FALSEP(port) return port; + *loc_loadpath = filename; + loadport = port; + linum = 1; + while(1) { + SCM form = newform; + newform = lread(port); + if (EOF_VAL==newform) { + close_port(port); + linum = olninum; + loadport = oloadport; + *loc_loadpath = oloadpath; + SIDEVAL(form, EOL); + return BOOL_T; + } + SIDEVAL(form, EOL); + } + } + return BOOL_T; +} +#ifdef CAUTIOUS +void scm_print_stack(stk) + SCM stk; +{ + switch (ilength(stk)) { + case -1: + lputs("\n; circular stacktrace!", cur_errp); + return; + case -2: + lputs("\n; stacktrace not a list?", cur_errp); + iprin1(stk, cur_errp, 1); + return; + default: + while NNULLP(stk) { + SCM ste = CAR(stk); + lputc('\n', cur_errp); + iprin1(ste, cur_errp, 1); + stk = CDR(stk); + } + } +} +SCM scm_stack_trace() +{ + if (0==ilength(stacktrace)) return BOOL_F; + scm_print_stack(stacktrace); + return BOOL_T; +} +#endif + +static void err_head(str) + char *str; +{ + int oerrno = errno; + exitval = MAKINUM(EXIT_FAILURE); + if NIMP(cur_outp) lfflush(cur_outp); + lputc('\n', cur_errp); + if(BOOL_F != *loc_loadpath) { + iprin1(*loc_loadpath, cur_errp, 1); + lputs(", line ", cur_errp); + intprint((long)linum, 10, cur_errp); + lputs(": ", cur_errp); + } + lfflush(cur_errp); + errno = oerrno; + if (cur_errp==def_errp) { + if (errno>0) perror(str); + fflush(stderr); + return; + } +} +void warn(str1, str2) + char *str1, *str2; +{ + err_head("WARNING"); + lputs("WARNING: ", cur_errp); + lputs(str1, cur_errp); + lputs(str2, cur_errp); + lputc('\n', cur_errp); + lfflush(cur_errp); +} + +SCM lerrno(arg) + SCM arg; +{ + int old = errno; + if (!UNBNDP(arg)) { + if FALSEP(arg) errno = 0; + else errno = INUM(arg); + } + return MAKINUM(old); +} +static char s_perror[] = "perror"; +SCM lperror(arg) + SCM arg; +{ + ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror); + err_head(CHARS(arg)); + return UNSPECIFIED; +} +static void def_err_response() +{ + SCM obj = *loc_errobj; +#ifdef CAUTIOUS + SCM stk = stacktrace; +#endif + DEFER_INTS; + err_head("ERROR"); + lputs("ERROR: ", cur_errp); + if (err_s_subr && *err_s_subr) { + lputs(err_s_subr, cur_errp); + lputs(": ", cur_errp); + } + if (err_pos==(char *)ARG1 && UNBNDP(*loc_errobj)) err_pos = (char *)WNA; +#ifdef nosve + if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp); + else if (WNA>(short)err_pos) { + lputs("Wrong type in arg", cur_errp); + lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp); + } +#else + if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp); + else if (WNA>(long)err_pos) { + lputs("Wrong type in arg", cur_errp); + lputc(err_pos ? '0'+(int)err_pos : ' ', cur_errp); + } +#endif + else { + lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp); + goto outobj; + } + if (IMP(obj) || SYMBOLP(obj) || (TYP16(obj)==tc7_port) + || (NFALSEP(procedurep(obj))) || (NFALSEP(numberp(obj)))) { +outobj: + if (!UNBNDP(obj)) { + lputs(((long)err_pos==WNA)?" given ":" ", cur_errp); + iprin1(obj, cur_errp, 1); + } + } + else lputs(" (see errobj)", cur_errp); +#ifdef CAUTIOUS + if NNULLP(stk) scm_print_stack(stk); +#endif + if UNBNDP(err_exp) goto getout; + if NIMP(err_exp) { + lputs("\n; in expression: ", cur_errp); + if NCONSP(err_exp) iprin1(err_exp, cur_errp, 1); + else if (UNDEFINED==CDR(err_exp)) + iprin1(CAR(err_exp), cur_errp, 1); + else iprlist("(... ", err_exp, ')', cur_errp, 1); + } + if NULLP(err_env) lputs("\n; in top level environment.", cur_errp); + else { + SCM env = err_env; + lputs("\n; in scope:", cur_errp); + while NNULLP(env) { + lputc('\n', cur_errp); + lputs("; ", cur_errp); + iprin1(CAR(CAR(env)), cur_errp, 1); + env = CDR(env); + } + } + getout: + lputc('\n', cur_errp); + lfflush(cur_errp); + err_exp = err_env = UNDEFINED; + if (errjmp_bad) { + iprin1(obj, cur_errp, 1); + lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp); +#ifdef vms + exit(EXIT_FAILURE); +#else + exit(errno? (long)errno : EXIT_FAILURE); +#endif + } + errno = 0; + ALLOW_INTS; +} +void everr(exp, env, arg, pos, s_subr) + SCM exp, env, arg; + char *pos, *s_subr; +{ + err_exp = exp; + err_env = env; + *loc_errobj = arg; + err_pos = pos; + err_s_subr = s_subr; +#ifndef CAUTIOUS + if (((~0x1fL) & (long)pos) || (WNA>(long)pos) + || NIMP(dynwinds) || errjmp_bad) +#endif + { + def_err_response(); + dowinds(EOL, ilength(dynwinds)); + abrt(); + } +#ifndef CAUTIOUS + /* We don't have to clear stacktrace because CAUTIOUS never gets here */ + /* We don't have to dowinds() because dynwinds is EOL */ + longjmp(CONT(rootcont)->jmpbuf, COOKIE((int)pos)); + /* will do error processing at stack base */ +#endif +} +void wta(arg, pos, s_subr) + SCM arg; +char *pos, *s_subr; +{ + everr(UNDEFINED, EOL, arg, pos, s_subr); +} +SCM cur_input_port() +{ + return cur_inp; +} +SCM cur_output_port() +{ + return cur_outp; +} +SCM cur_error_port() +{ + return cur_errp; +} +char s_cur_inp[] = "set-current-input-port"; +char s_cur_outp[] = "set-current-output-port"; +char s_cur_errp[] = "set-current-error-port"; +SCM set_inp(port) + SCM port; +{ + SCM oinp = cur_inp; + ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_cur_inp); + cur_inp = port; + return oinp; +} +SCM set_outp(port) + SCM port; +{ + SCM ooutp = cur_outp; + ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp); + cur_outp = port; + return ooutp; +} +SCM set_errp(port) + SCM port; +{ + SCM oerrp = cur_errp; + ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp); + cur_errp = port; + return oerrp; +} + +static iproc subr0s[] = { + {&s_cur_inp[4], cur_input_port}, + {&s_cur_outp[4], cur_output_port}, + {&s_cur_errp[4], cur_error_port}, + {"transcript-off", trans_off}, + {"program-arguments", prog_args}, + {"line-number", line_num}, + {"abort", abrt}, + {s_restart, restart}, +#ifdef CAUTIOUS + {"stack-trace", scm_stack_trace}, +#endif + {0, 0}}; + +static iproc subr1s[] = { + {s_cur_inp, set_inp}, + {s_cur_outp, set_outp}, + {s_cur_errp, set_errp}, + {"transcript-on", trans_on}, + {s_tryload, tryload}, + {s_load_string, scm_load_string}, + {s_eval_string, scm_eval_string}, + {s_perror, lperror}, + {"make-arbiter", makarb}, + {s_tryarb, tryarb}, + {s_relarb, relarb}, + {0, 0}}; + +static iproc subr1os[] = { + {s_read, lread}, + {s_read_char, scm_read_char}, + {s_peek_char, peek_char}, + {s_newline, newline}, + {s_flush, lflush}, +#ifndef GO32 + {s_char_readyp, char_readyp}, +#endif + {"quit", quit}, + {"verbose", prolixity}, + {"errno", lerrno}, + {s_execpath, scm_execpath}, + {0, 0}}; + +static iproc subr2os[] = { + {s_write, lwrite}, + {s_display, display}, + {s_write_char, write_char}, +#ifdef CAN_DUMP + {s_unexec, scm_unexec}, +#endif + {0, 0}}; + +static smobfuns arbsmob = {markcdr, free0, prinarb}; +char s_ccl[] = "char-code-limit"; + +void init_repl( iverbose ) + int iverbose; +{ + sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT)); + loc_errobj = &CDR(sysintern("errobj", UNDEFINED)); + loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F)); + transcript = BOOL_F; + trans = 0; + linum = 1; + verbose = iverbose; + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + make_subr("room", tc7_lsubr, lroom); +#ifndef GO32 + add_feature(s_char_readyp); +#endif +#ifdef CAN_DUMP + if (!execpath) execpath = dld_find_executable(CHARS(CAR(progargs))); + add_feature("dump"); + scm_ldstr("\ +(define (dump file . thunk)\n\ + (cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\ + ((not (car thunk)) (set! *argv* #f))\n\ + ((boolean? (car thunk)))\n\ + (else (set! boot-tail (car thunk))))\n\ + (set! restart exec-self)\n\ + (unexec file))\n\ +"); +#endif +#ifdef ARM_ULIB + set_erase(); +#endif + tc16_arbiter = newsmob(&arbsmob); +} +void final_repl() +{ + loc_errobj = (SCM *)&tmp_errobj; + loc_loadpath = (SCM *)&tmp_loadpath; + loadport = UNDEFINED; + transcript = BOOL_F; + trans = 0; + linum = 1; +} @@ -0,0 +1,661 @@ +#include "scm.h" +#include "regex.h" +#include <stdio.h> + +static char rcsid[] = + "$Id: rgx.c, v 1.20 1995/02/15 04:39:45 dpb Exp $"; + +#ifdef HAVE_ALLOCA +# include <alloca.h> +# define ALLOCA_PROTECT typedef int foobazzz +# define ALLOCA alloca +#else +# define ALLOCA_PROTECT SCM alloca_protect=EOL +# define ALLOCA(size) \ + (alloca_protect=cons(makstr((long)(size)), alloca_protect), \ + (void *)CDR(CAR(alloca_protect))) + +#endif + +#ifdef _GNU_SOURCE +/* following two lines stolen from GNU regex.c */ +# define CHAR_SET_SIZE 256 +# define ISUPPER(c) (isascii (c) && isupper (c)) +#endif + +/* forward function defs */ + +SCM lregsearch(); +SCM lregsearchv(); + +/* Posix regexp bindings. */ + +static char s_regex[] = "regex"; +static char s_regcomp[] = "regcomp", s_regerror[] = "regerror"; +static char s_regexec[] = "regexec", s_regmatp[] = "regmatch?"; +static char s_regsearch[] = "regsearch", s_regmatch[] = "regmatch"; +static char s_regsearchv[] = "regsearchv", s_regmatchv[] = "regmatchv"; +static char s_stringsplit[] = "string-split"; +static char s_stringsplitv[] = "string-splitv"; +static char s_stringedit[] = "string-edit"; + +#define s_error &s_regerror[3] + +#define RGX_INFO(obj) ((regex_info*)CDR(obj)) +#define RGX_PATTERN(obj) (((regex_info*)CDR(obj))->pattern) +#define RGX(obj) (&((regex_info*)CDR(obj))->rgx) +#ifndef _GNU_SOURCE +# define RGX2(obj) (&((regex_info*)CDR(obj))->rgx_anchored) +#endif + +#define FIXUP_REGEXP(prog) \ +{ \ + if (STRINGP(prog)) \ + prog = lregcomp(prog, UNDEFINED); \ + if (NIMP(prog) && CONSP(prog) && STRINGP(CAR(prog)) && \ + NIMP(CDR(prog)) && CONSP(CDR(prog)) && STRINGP(CAR(CDR(prog)))) \ + prog = lregcomp(CAR(prog), CAR(CDR(prog))); \ +} + +typedef struct regex_info { + SCM pattern; /* string we compiled to create our reg exp */ + regex_t rgx; +#ifndef _GNU_SOURCE + int options; /* for anchored pattern when matching */ + regex_t rgx_anchored; +#endif +} regex_info; + +sizet fregex(ptr) + CELLPTR ptr; +{ + regfree(RGX(ptr)); +#ifndef _GNU_SOURCE + /* options are null => we compiled the anchored pattern */ + if (RGX_INFO(ptr)->options==NULL) + regfree(RGX2(ptr)); +#endif + free(CHARS(ptr)); + return sizeof(regex_t); +} + +int prinregex(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#<regex ", port); + intprint(CDR(exp), 16, port); + lputc(' ', port); + iprin1(RGX_PATTERN(exp), port, writing); + lputc('>', port); + return 1; +} + +SCM markregex(ptr) + SCM ptr; +{ + SETGC8MARK(ptr); + SETGC8MARK(RGX_PATTERN(ptr)); + return BOOL_F; +} + +int tc16_rgx; +static smobfuns rgxsmob = {markregex, fregex, prinregex}; + +SCM lregerror(scode) + SCM scode; +{ + int code, len; + SCM str; + ASSERT(INUMP(scode), scode, ARG1, s_regerror); + code = INUM(scode); + if (code < 0) + return makfromstr("Invalid code", sizeof("Invalid code")-1); + /* XXX - is regerror posix or not? */ +#ifdef __REGEXP_LIBRARY_H__ + /* XXX - gnu regexp doesn't use the re parameter, so we will + ignore it in a very untidy way. */ + len = regerror(code, 0, 0, 0); + str = makstr(len-1); + regerror(code, 0, CHARS(str), len); +#else + str = makfromstr(s_error, (sizet)5); +#endif + return str; +} + +SCM lregcomp(pattern, flags) + SCM pattern, flags; +{ + SCM z; + int i, options; + regex_t *prog; + regex_info *info; + char *flagchars; +#ifdef _GNU_SOURCE + int fastmap = 0; + int ignore_case = 0; + char *err_msg; +#endif + + ASSERT(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp); + ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)), + flags, ARG2, s_regcomp); + NEWCELL(z); + DEFER_INTS; + SETCHARS(z, info=(regex_info*)must_malloc((long)sizeof(regex_info), s_regex)); + prog = &(info->rgx); + CAR(z) = tc16_rgx; +#ifdef __REGEXP_LIBRARY_H__ + for(i=sizeof(regex_t);i--;((char *)prog)[i] = 0); +# ifndef _GNU_SOURCE + { + regex_t *prog2; + prog2 = &(info->rgx_anchored); + for(i=sizeof(regex_t);i--;((char *)prog2)[i] = 0); + } +# endif +#endif + + ALLOW_INTS; + info->pattern = pattern; + +#ifdef _GNU_SOURCE + options = RE_SYNTAX_POSIX_EXTENDED; +#else + options = REG_EXTENDED; +#endif + + if (!UNBNDP(flags)) { + flagchars = CHARS(flags); + for (i=0; i<LENGTH(flags); i++) + switch (flagchars[i]) { +#ifdef _GNU_SOURCE + case 'n': + options |= RE_HAT_LISTS_NOT_NEWLINE; + options &= (~RE_DOT_NEWLINE); + break; + case 'i': + ignore_case = 1; + break; + case '0': + options &= (~RE_DOT_NOT_NULL); + break; + case 'f': + fastmap = 1; + break; +#else + case 'n': + options |= REG_NEWLINE; + break; + case 'i': + options |= REG_ICASE; + break; +#endif + } + } + +#ifdef _GNU_SOURCE + DEFER_INTS; + if (fastmap) + prog->fastmap = must_malloc(CHAR_SET_SIZE, s_regex); + + if (ignore_case) { + prog->translate = must_malloc(CHAR_SET_SIZE, s_regex); + for (i = 0; i < CHAR_SET_SIZE; i++) + prog->translate[i] = ISUPPER (i) ? tolower (i) : i; + } + + re_set_syntax(options); + err_msg = (char *)re_compile_pattern(CHARS(pattern), LENGTH(pattern), prog); + ALLOW_INTS; + prog->regs_allocated = REGS_FIXED; + + /* if error, compile using regcomp to get the error number */ + if (err_msg) { + int i; + char *tmppat; + SCM protect; + + /* Fixup in case pattern has null characters */ + tmppat = CHARS(protect=makstr(LENGTH(pattern))); + bcopy(CHARS(pattern), tmppat, LENGTH(pattern)); + for (i=0; i<LENGTH(pattern); i++) + if (tmppat[i] == 0) + tmppat[i] = ' '; + + i = regcomp(prog, tmppat, options); + z = MAKINUM(i); + } +#else + info->options = options; + i = regcomp(prog, CHARS(pattern), options); + if (i) z = MAKINUM(i); +#endif + return z; +} + +SCM lregexec(prog, str) + SCM prog, str; +{ + ALLOCA_PROTECT; + + FIXUP_REGEXP(prog); + ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regexec); + ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regexec); + +#ifdef _GNU_SOURCE + return lregsearchv(prog, str, EOL); +#else /* not _GNU_SOURCE */ + { + size_t nsub; + SCM ans; + regmatch_t *pm; + int flags = 0; /* XXX - optional arg? */ + + nsub = RGX(prog)->re_nsub + 1; /* XXX - is this posix? */ + pm = ALLOCA(nsub * sizeof(regmatch_t)); + if (regexec(RGX(prog), CHARS(str), nsub, pm, flags) != 0) + ans = BOOL_F; + else { + ans = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L)); + while (nsub--) { + VELTS(ans)[2*nsub+0] = MAKINUM(pm[nsub].rm_so); + VELTS(ans)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo); + } + } + return ans; + } +#endif /* _GNU_SOURCE */ +} + +SCM lregmatp(prog, str) + SCM prog, str; +{ + FIXUP_REGEXP(prog); + ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regmatp); + ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regmatp); + +#ifdef _GNU_SOURCE + return (lregsearch(prog, str, EOL)==BOOL_F)?BOOL_F:BOOL_T; +#else /* not _GNU_SOURCE */ + { + int flags = 0; /* XXX - optional arg? */ + + flags = regexec(RGX(prog), CHARS(str), 0, NULL, flags); + if (!flags) return BOOL_T; + if (REG_NOMATCH!=flags) wta(MAKINUM(flags), s_error, s_regmatp); + return BOOL_F; + } +#endif +} + +#define SCALAR 0 +#define VECTOR 1 + +#define MATCH 0 +#define SEARCH 1 + +SCM lregsearchmatch(prog, str, args, search, vector) + SCM prog, str, args; + int vector, search; +{ + int len = ilength(args); + int start, size, nsub; + SCM matches; + ALLOCA_PROTECT; + + FIXUP_REGEXP(prog); + ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regsearch); + ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regsearch); + ASSERT(len<=2, args, WNA, s_regsearch); + ASSERT((len<1)||(INUMP(CAR(args))), CAR(args), ARG3, s_regsearch); + ASSERT((len<2)||(INUMP(CAR(CDR(args)))), CAR(CDR(args)), ARG4, s_regsearch); + + start = (len>=1)?(INUM(CAR(args))):0; + size = (len>=2)?(INUM(CAR(CDR(args)))):LENGTH(str); + +#ifdef _GNU_SOURCE + { + int ret, dir=1; + struct re_registers regs, *pregs=NULL; + + if (search && start<0) + start *= -1, dir = -1; + + if (vector) { + pregs = ®s; + nsub = RGX(prog)->re_nsub + 1; + regs.num_regs = nsub; + + regs.start = ALLOCA(nsub * sizeof(regoff_t)); + regs.end = ALLOCA(nsub * sizeof(regoff_t)); + } + + if (search) + ret = re_search(RGX(prog), CHARS(str), size, start, dir*size, pregs); + else + ret = re_match(RGX(prog), CHARS(str), size, start, pregs); + + if (ret < 0) + return BOOL_F; + + if (!vector) + return MAKINUM(ret); + + matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L)); + while (nsub--) { + VELTS(matches)[2*nsub+0] = MAKINUM(regs.start[nsub]); + VELTS(matches)[2*nsub+1] = MAKINUM(regs.end[nsub]); + } + return matches; + } +#else /* not _GNU_SOURCE */ + { + regex_t *regexp; + regmatch_t *pm; + char *search_string; + if (size > LENGTH(str)) + size = LENGTH(str); + + if (start<0 || start >= size) + return BOOL_F; + + if (size < LENGTH(str)) { + search_string = ALLOCA(size-start+1); + bcopy(CHARS(str)+start, search_string, size-start); + search_string[size-start] = 0; + } else + search_string = CHARS(str)+start; + + nsub = RGX(prog)->re_nsub + 1; + pm = ALLOCA(nsub * sizeof(regmatch_t)); + if (search) + regexp = RGX(prog); + else { + /* doing a match */ + if (RGX_INFO(prog)->options) { + /* strlen & strcpy OK, posix patterns are null terminated */ + char *pattern; + + pattern = ALLOCA(strlen(CHARS(RGX_PATTERN(prog)))+2); + pattern[0] = '^'; + strcpy(pattern+1, CHARS(RGX_PATTERN(prog))); + regcomp(RGX2(prog), pattern, RGX_INFO(prog)->options); + RGX_INFO(prog)->options = 0; + } + regexp = RGX2(prog); + } + + if (regexec(regexp, search_string, nsub, pm, 0) != 0) + return BOOL_F; + + if (vector) { + matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L)); + while (nsub--) { + VELTS(matches)[2*nsub+0] = MAKINUM(pm[nsub].rm_so + start); + VELTS(matches)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo + start); + } + return matches; + } + + if (search) + return MAKINUM(pm[0].rm_so + start); + else + return MAKINUM(pm[0].rm_eo - pm[0].rm_so); + } + +#endif /* _GNU_SOURCE */ +} + +SCM lregsearch(prog, str, args) + SCM prog, str, args; +{ + return lregsearchmatch(prog, str, args, SEARCH, SCALAR); +} + +SCM lregsearchv(prog, str, args) + SCM prog, str, args; +{ + return lregsearchmatch(prog, str, args, SEARCH, VECTOR); +} + +SCM lregmatch(prog, str, args) + SCM prog, str, args; +{ + return lregsearchmatch(prog, str, args, MATCH, SCALAR); +} + +SCM lregmatchv(prog, str, args) + SCM prog, str, args; +{ + return lregsearchmatch(prog, str, args, MATCH, VECTOR); +} + +SCM stringsplitutil(prog, str, vector) + SCM prog, str; + int vector; +{ + int anchor, match_start, match_end, num_substrings, num_elements; + int search_base; + SCM next_break, substrings, ret; + SCM st_start, st_end; + + FIXUP_REGEXP(prog); + ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringsplit); + ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_stringsplit); + + substrings = EOL; + anchor = 0; + search_base = 0; + num_substrings = 0; + next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); + + while (next_break != BOOL_F) { + match_start = INUM(VELTS(next_break)[0]); + match_end = INUM(VELTS(next_break)[1]); + + if (match_start < match_end) { + substrings=cons2(MAKINUM(anchor), MAKINUM(match_start), substrings); + anchor = match_end; + num_substrings++; + } + + search_base = ((match_end>search_base)?match_end:(search_base+1)); + next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); + } + + /* get that tail bit */ + if (anchor < LENGTH(str)) { + substrings = cons2(MAKINUM(anchor), MAKINUM(LENGTH(str)), substrings); + num_substrings++; + } + + num_elements = vector?(2*num_substrings):num_substrings; + ret = make_vector(MAKINUM(num_elements), EOL); + + while (num_substrings--) { + st_start = CAR(substrings); + st_end = CAR(CDR(substrings)); + + if (vector) { + VELTS(ret)[num_substrings*2+0] = st_start; + VELTS(ret)[num_substrings*2+1] = st_end; + } else + VELTS(ret)[num_substrings] = substring(str, st_start, st_end); + + substrings = CDR(CDR(substrings)); + } + + return ret; +} + +SCM lstringsplit(prog, str) + SCM prog, str; +{ + return stringsplitutil(prog, str, SCALAR); +} + +SCM lstringsplitv(prog, str) + SCM prog, str; +{ + return stringsplitutil(prog, str, VECTOR); +} + +typedef struct _item { + struct _item *next; + char *string; + int start; + int end; +} *editItem; + +#define PUSH(list, string_parm, start_parm, end_parm) \ + { \ + editItem item; \ + \ + item = ALLOCA(sizeof(*item)); \ + item->next = list; \ + list = item; \ + item->string = string_parm; \ + item->start = start_parm; \ + item->end = end_parm; \ + } + +/* (string-edit <re> <edit-spec> <string> [<count>]) */ +SCM lstringedit(prog, editspec, args) + SCM prog, editspec, args; +{ + int match_start, match_end, search_base, editcount; + int total_len; + int i, args_len, anchor, maxsubnum; + int backslash; + char *ptr; + editItem editlist, substrings, edit; + SCM str, count, next_edit; + SCM result; + ALLOCA_PROTECT; + + args_len = ilength(args); + + FIXUP_REGEXP(prog); + ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringedit); + ASSERT(NIMP(editspec) && STRINGP(editspec), editspec, ARG2, s_stringedit); + ASSERT((args_len==1)||(args_len==2), args, WNA, s_stringedit); + + str = CAR(args); + ASSERT(NIMP(str)&&STRINGP(str), str, ARG3, s_stringedit); + + if (args_len==2) { + count = CAR(CDR(args)); + ASSERT(INUMP(count)||(count==BOOL_T), count, ARG4, s_stringedit); + } else + count = MAKINUM(1); + + /* process the editspec - break it into a list of dotted pairs + * of integers for substrings to be inserted and + * integers representing matched subexpressions that + * should be inserted. + */ + + maxsubnum = RGX(prog)->re_nsub; + anchor = 0; + backslash = 0; + editlist = NULL; + ptr = CHARS(editspec); + + for (i=0; i<LENGTH(editspec); i++) { + if (backslash && (ptr[i]>='0') && (ptr[i] <='9') && + ((ptr[i]-'0')<=maxsubnum)) + { + if ((i-1)>anchor) + PUSH(editlist, CHARS(editspec), anchor, i-1); + + PUSH(editlist, CHARS(editspec), ptr[i]-'0', -1); + anchor = i+1; + } + backslash = (ptr[i] == '\\')?1:0; + } + + if (anchor < LENGTH(editspec)) + PUSH(editlist, CHARS(editspec), anchor, LENGTH(editspec)); + + /* now, reverse the list of edit items */ + { + editItem prev, cur, next; + + for (prev=NULL, cur=editlist; cur; prev=cur, cur=next) { + next = cur->next; + cur->next = prev; + } + editlist = prev; + } + + anchor = 0; + search_base = 0; + editcount = 0; + substrings = NULL; + + next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); + + while (next_edit != BOOL_F) { + if (INUMP(count) && (editcount==INUM(count))) + break; + + match_start = INUM(VELTS(next_edit)[0]); + match_end = INUM(VELTS(next_edit)[1]); + + if (match_start < match_end) { + PUSH(substrings, CHARS(str), anchor, match_start); + anchor = match_end; + } + + for (edit=editlist; edit; edit=edit->next) { + if (edit->end == -1) { + /* A backslash number in the original editspec */ + PUSH(substrings, CHARS(str), + INUM(VELTS(next_edit)[edit->start*2+0]), + INUM(VELTS(next_edit)[edit->start*2+1])); + } else + /* normal string in the editspec */ + PUSH(substrings, edit->string, edit->start, edit->end); + } + + editcount++; + search_base = ((match_end>search_base)?match_end:(search_base+1)); + next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL)); + } + + /* get that tail bit */ + if (anchor < LENGTH(str)) + PUSH(substrings, CHARS(str), anchor, LENGTH(str)); + + /* assemble the result string */ + for (edit=substrings, total_len=0; edit; edit=edit->next) + total_len += (edit->end - edit->start); + + result = makstr(total_len); + ptr = CHARS(result) + total_len; /* point at the null at the end */ + + for (edit=substrings; edit; edit=edit->next) { + ptr -= (edit->end - edit->start); + bcopy(edit->string + edit->start, ptr, edit->end - edit->start); + } + return result; +} +#undef PUSH + +void init_rgx() +{ + tc16_rgx = newsmob(&rgxsmob); + make_subr(s_regcomp, tc7_subr_2o, lregcomp); + make_subr(s_regexec, tc7_subr_2, lregexec); + make_subr(s_regmatp, tc7_subr_2, lregmatp); + make_subr(s_regerror, tc7_subr_1, lregerror); + make_subr(s_regsearch, tc7_lsubr_2, lregsearch); + make_subr(s_regsearchv, tc7_lsubr_2, lregsearchv); + make_subr(s_regmatch, tc7_lsubr_2, lregmatch); + make_subr(s_regmatchv, tc7_lsubr_2, lregmatchv); + make_subr(s_stringsplit, tc7_subr_2, lstringsplit); + make_subr(s_stringsplitv, tc7_subr_2, lstringsplitv); + make_subr(s_stringedit, tc7_lsubr_2, lstringedit); + add_feature(s_regex); +} @@ -0,0 +1,335 @@ +/* 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. + */ + +/* "rope.c" interface between C and SCM. + Author: Aubrey Jaffer */ + +#include "scm.h" + + /* Numeric conversions */ + /* Convert longs to SCM */ +SCM long2num(sl) + long sl; +{ + if (!FIXABLE(sl)) { +# ifdef BIGDIG + return long2big(sl); +# else +# ifdef FLOATS + return makdbl((double) sl, 0.0); +# else + return BOOL_F; +# endif +# endif + } + return MAKINUM(sl); +} +SCM ulong2num(sl) + unsigned long sl; +{ + if (!POSFIXABLE(sl)) { +#ifdef BIGDIG + return ulong2big(sl); +#else +# ifdef FLOATS + return makdbl((double) sl, 0.0); +# else + return BOOL_F; +# endif +#endif + } + return MAKINUM(sl); +} + + /* Convert SCM to numbers */ +unsigned char num2uchar(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + unsigned long res = INUM(num); + ASSERT(INUMP(num) && (255L >= res),num,pos,s_caller); + return (unsigned char) res; +} +unsigned short num2ushort(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + unsigned long res = INUM(num); + ASSERT(INUMP(num) && (65535L >= res),num,pos,s_caller); + return (unsigned short) res; +} +unsigned long num2ulong(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + unsigned long res; + if INUMP(num) { + ASRTGO(0 < num, errout); + res = INUM((unsigned long)num); + return res; + } + ASRTGO(NIMP(num), errout); +#ifdef FLOATS + if REALP(num) { + double u = REALPART(num); + if ((0 <= u) && (u <= (unsigned long)~0L)) { + res = u; + return res; + } + } +#endif +#ifdef BIGDIG + if (TYP16(num)==tc16_bigpos) { + sizet l = NUMDIGS(num); + ASRTGO(DIGSPERLONG >= l, errout); + res = 0; + for(;l--;) res = BIGUP(res) + BDIGITS(num)[l]; + return res; + } +#endif + errout: wta(num, pos, s_caller); +} +long num2long(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + long res; + if INUMP(num) { + res = INUM((long)num); + return res; + } + ASRTGO(NIMP(num), errout); +# ifdef FLOATS + if REALP(num) { + double u = REALPART(num); + if (((MOST_NEGATIVE_FIXNUM * 4) <= u) + && (u <= (MOST_POSITIVE_FIXNUM * 4 + 3))) { + res = u; + return res; + } + } +# endif +# ifdef BIGDIG + if BIGP(num) { + sizet l = NUMDIGS(num); + ASRTGO(DIGSPERLONG >= l, errout); + res = 0; + for(;l--;) res = BIGUP(res) + BDIGITS(num)[l]; + ASRTGO(0<res, errout); + return (tc16_bigpos==TYP16(num) ? res : -res); + } +# endif + errout: wta(num, pos, s_caller); +} +#ifdef FLOATS +double num2dbl(num, pos, s_caller) + SCM num; + char *pos, *s_caller; +{ + if INUMP(num) return (double)INUM(num); + ASRTGO(NIMP(num), errout); + if REALP(num) return REALPART(num); +#ifdef BIGDIG + if BIGP(num) return big2dbl(num); +#endif + errout: wta(num, pos, s_caller); +} +#endif + + + /* Convert (arrays of) strings to SCM */ +SCM makfromstr(src, len) + char *src; + sizet len; +{ + SCM s; + register char *dst; + s = makstr((long)len); + dst = CHARS(s); + while (len--) *dst++ = *src++; + return s; +} +SCM makfrom0str(src) + char *src; +{ + if (!src) return BOOL_F; + return makfromstr(src, (sizet) strlen(src)); +} +/* converts C array of strings to SCM list of strings. */ +/* If argc < 0, a null terminated array is assumed. */ +SCM makfromstrs(argc, argv) + int argc; + char **argv; +{ + int i = argc; + SCM lst = EOL; + if (0 > i) for(i = 0; argv[i]; i++); + while (i--) lst = cons(makfrom0str(argv[i]), lst); + return lst; +} +/* Converts SCM list of strings to NULL terminated array of strings. */ +/* INTS must be DEFERed around this call and the use of the returned array. */ +char **makargvfrmstrs(args, s_name) + SCM args; + char *s_name; +{ + char **argv; + int argc = ilength(args); + argv = (char **)must_malloc((1L+argc)*sizeof(char *), s_vector); + for(argc = 0; NNULLP(args); args=CDR(args), ++argc) { + ASSERT(NIMP(CAR(args)) && STRINGP(CAR(args)), CAR(args), ARG2, s_name); + { + sizet len = 1 + LENGTH(CAR(args)); + char *dst = (char *)must_malloc((long)len, s_string); + char *src = CHARS(CAR(args)); + while (len--) dst[len] = src[len]; + argv[argc] = dst; + } + } + argv[argc] = 0; + return argv; +} +void must_free_argv(argv) + char **argv; +{ + char **av = argv; + while(!(*av)) free(*(av++)); + free(argv); +} + + /* Hooks to call SCM from C */ +SCM scm_evstr(str) + char *str; +{ + SCM lsym; + NEWCELL(lsym); + SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol); + SETCHARS(lsym, str); + return scm_eval_string(lsym); +} +void scm_ldstr(str) + char *str; +{ + SCM lsym; + NEWCELL(lsym); + SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol); + SETCHARS(lsym, str); + scm_load_string(lsym); +} +int scm_ldfile(path) + char *path; +{ + SCM name = makfrom0str(path); + *loc_errobj = name; + return BOOL_F==tryload(name); +} +int scm_ldprog(path) + char *path; +{ + SCM name = makfrom0str(path); + *loc_errobj = name; + return + BOOL_F==scm_evstr("(try-load (in-vicinity (program-vicinity) errobj))"); +} + + /* Get byte address of SCM array */ +#ifdef ARRAYS +long aind P((SCM ra, SCM args, char *what)); +unsigned long scm_addr(args, s_name) + SCM args; + char *s_name; +{ + long pos; + unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */ + SCM v; + ASRTGO(NIMP(args), wna); + v = CAR(args); + args = CDR(args); + if IMP(v) {goto badarg;} + else if ARRAYP(v) { + pos = aind(v, args, s_name); + v = ARRAY_V(v); + } + else { + if NIMP(args) { + ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_name); + pos = INUM(CAR(args)); + ASRTGO(NULLP(CDR(args)), wna); + } + else if NULLP(args) pos = 0; + else { + ASSERT(INUMP(args), args, ARG2, s_name); + pos = INUM(args); + } + ASRTGO(pos >= 0 && pos < LENGTH(v), outrng); + } + switch TYP7(v) { + case tc7_string: + ptr = (unsigned long)&(CHARS(v)[pos]); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + ptr = (unsigned long)&(((float *)CDR(v))[pos]); + break; +# endif + case tc7_cvect: pos = 2 * pos; + case tc7_dvect: ptr = (unsigned long)&(((double *)CDR(v))[pos]); + break; +# endif + case tc7_bvect: ASRTGO(0==(pos%LONG_BIT), outrng); + pos = pos/LONG_BIT; + case tc7_uvect: + case tc7_ivect: + case tc7_vector: ptr = (unsigned long)&(VELTS(v)[pos]); + break; + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_name); + default: + badarg: wta(v, (char *)ARG1, s_name); + wna: wta(UNDEFINED, (char *)WNA, s_name); + } + return ptr; +} +#endif /* ARRAYS */ + +void init_rope() +{ +} @@ -0,0 +1,172 @@ +/* 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. + */ + +/* "sc2.c" R2RS and R3RS procedures not in R4RS. + Author: Aubrey Jaffer */ + +#include "scm.h" + +static char s_last_pair[] = "last-pair"; +SCM last_pair(sx) + SCM sx; +{ + register SCM res = sx; + register SCM x; + ASSERT(NIMP(res) && CONSP(res), res, ARG1, s_last_pair); + while (!0) { + x = CDR(res); + if (IMP(x) || NCONSP(x)) return res; + res = x; + x = CDR(res); + if (IMP(x) || NCONSP(x)) return res; + res = x; + sx = CDR(sx); + ASSERT(x != sx, sx, ARG1, s_last_pair); + } +} + +static char s_subml[] = "substring-move-left!"; +SCM subml(str1, start1, args) + SCM str1, start1, args; +{ + SCM end1, str2, start2; + long i, j, e; + ASSERT(3==ilength(args), args, WNA, s_subml); + end1 = CAR(args); args = CDR(args); + str2 = CAR(args); args = CDR(args); + start2 = CAR(args); + ASSERT(NIMP(str1) && STRINGP(str1), str1, ARG1, s_subml); + ASSERT(INUMP(start1), start1, ARG2, s_subml); + ASSERT(INUMP(end1), end1, ARG3, s_subml); + ASSERT(NIMP(str2) && STRINGP(str2), str2, ARG4, s_subml); + ASSERT(INUMP(start2), start2, ARG5, s_subml); + i = INUM(start1), j = INUM(start2), e = INUM(end1); + ASSERT(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_subml); + ASSERT(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_subml); + ASSERT(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_subml); + ASSERT(e-i+j <= LENGTH(str2), start2, OUTOFRANGE, s_subml); + while(i<e) CHARS(str2)[j++] = CHARS(str1)[i++]; + return UNSPECIFIED; +} +static char s_submr[] = "substring-move-right!"; +SCM submr(str1, start1, args) + SCM str1, start1, args; +{ + SCM end1, str2, start2; + long i, j, e; + ASSERT(3==ilength(args), args, WNA, s_submr); + end1 = CAR(args); args = CDR(args); + str2 = CAR(args); args = CDR(args); + start2 = CAR(args); + ASSERT(NIMP(str1) && STRINGP(str1), str1, ARG1, s_submr); + ASSERT(INUMP(start1), start1, ARG2, s_submr); + ASSERT(INUMP(end1), end1, ARG3, s_submr); + ASSERT(NIMP(str2) && STRINGP(str2), str2, ARG4, s_submr); + ASSERT(INUMP(start2), start2, ARG5, s_submr); + i = INUM(start1), j = INUM(start2), e = INUM(end1); + ASSERT(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_submr); + ASSERT(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_submr); + ASSERT(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_submr); + ASSERT((j = e-i+j) <= LENGTH(str2), start2, OUTOFRANGE, s_submr); + while(i<e) CHARS(str2)[--j] = CHARS(str1)[--e]; + return UNSPECIFIED; +} +static char s_subfl[] = "substring-fill!"; +SCM subfl(str, start, args) + SCM str, start, args; +{ + SCM end, fill; + long i, e; + char c; + ASSERT(2==ilength(args), args, WNA, s_subfl); + end = CAR(args); args = CDR(args); + fill = CAR(args); + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_subfl); + ASSERT(INUMP(start), start, ARG2, s_subfl); + ASSERT(INUMP(end), end, ARG3, s_subfl); + ASSERT(ICHRP(fill), fill, ARG4, s_subfl); + i = INUM(start), e = INUM(end);c = ICHR(fill); + ASSERT(i <= LENGTH(str) && i >= 0, start, OUTOFRANGE, s_subfl); + ASSERT(e <= LENGTH(str) && e >= 0, end, OUTOFRANGE, s_subfl); + while(i<e) CHARS(str)[i++] = c; + return UNSPECIFIED; +} + +static char s_strnullp[] = "string-null?"; +SCM strnullp(str) + SCM str; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_strnullp); + if LENGTH(str) return BOOL_F; + else return BOOL_T; +} + +static char s_appendb[] = "append!"; +SCM appendb(args) + SCM args; +{ + SCM arg; + tail: + if NULLP(args) return EOL; + arg = CAR(args); + ASSERT(NULLP(arg) || (NIMP(arg) && CONSP(arg)), arg, ARG1, s_appendb); + args = CDR(args); + if NULLP(args) return arg; + if NULLP(arg) goto tail; + CDR(last_pair(arg)) = appendb(args); + return arg; +} + +static iproc lsubr2s[] = { + {s_subml, subml}, + {s_submr, submr}, + {s_subfl, subfl}, + {0, 0}}; + +void init_sc2() +{ + make_subr(s_last_pair, tc7_subr_1, last_pair); + make_subr(s_strnullp, tc7_subr_1, strnullp); + make_subr(s_appendb, tc7_lsubr, appendb); + init_iprocs(lsubr2s, tc7_lsubr_2); + add_feature("rev2-procedures"); + add_feature("rev3-procedures"); +} @@ -0,0 +1,2393 @@ +/* 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. + */ + +/* "scl.c" non-IEEE utility functions and non-integer arithmetic. + Authors: Jerry D. Hedden and Aubrey Jaffer */ + +#include "scm.h" + +#ifdef FLOATS +# include <math.h> + +static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", + s_magnitude[] = "magnitude", s_angle[] = "angle", + s_real_part[] = "real-part", s_imag_part[] = "imag-part", + s_in2ex[] = "inexact->exact"; +static char s_expt[] = "$expt", s_atan2[] = "$atan2"; +static char s_memv[] = "memv", s_assv[] = "assv"; +#endif + +SCM sys_protects[NUM_PROTECTS]; +sizet num_protects = NUM_PROTECTS; + +char s_inexactp[] = "inexact?"; +static char s_zerop[] = "zero?", + s_positivep[] = "positive?", s_negativep[] = "negative?"; +static char s_eqp[] = "=", s_lessp[] = "<", s_grp[] = ">"; +static char s_leqp[] = "<=", s_greqp[] = ">="; +static char s_max[] = "max", s_min[] = "min"; +char s_sum[] = "+", s_difference[] = "-", s_product[] = "*", + s_divide[] = "/"; +static char s_number2string[] = "number->string", + s_str2number[] = "string->number"; + +static char s_list_tail[] = "list-tail"; +static char s_str2list[] = "string->list"; +static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!"; +static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!"; + +/*** NUMBERS -> STRINGS ***/ +#ifdef FLOATS +int 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 sizet idbl2str(f, a) + double f; +char *a; +{ + int efmt, dpt, d, i, wp = dblprec; + 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 sizet iflo2str(flt, str) + SCM flt; + char *str; +{ + sizet i; +# ifdef SINGLES + if SINGP(flt) i = idbl2str(FLO(flt), str); + else +# endif + i = idbl2str(REAL(flt), str); + if CPLXP(flt) { + if(0 <= IMAG(flt)) /* jeh */ + str[i++] = '+'; /* jeh */ + i += idbl2str(IMAG(flt), &str[i]); + str[i++] = 'i'; + } + return i; +} +#endif /* FLOATS */ + +sizet iint2str(num, rad, p) + long num; + int rad; + char *p; +{ + 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 BIGDIG +static SCM big2str(b, radix) + SCM b; + register unsigned int radix; +{ + SCM t = copybig(b, 0); /* sign of temp doesn't matter */ + register BIGDIG *ds = BDIGITS(t); + sizet i = NUMDIGS(t); + sizet j = radix==16 ? (BITSPERDIG*i)/4+2 + : radix >= 10 ? (BITSPERDIG*i*241L)/800+2 + : (BITSPERDIG*i)+2; + sizet k = 0; + sizet radct = 0; + sizet ch; /* jeh */ + BIGDIG radpow = 1, radmod = 0; + SCM ss = makstr((long)j); + char *s = CHARS(ss), c; + while ((long) radpow * radix < BIGRAD) { + radpow *= radix; + radct++; + } + s[0] = tc16_bigneg==TYP16(b) ? '-' : '+'; + while ((i || radmod) && j) { + if (k==0) { + radmod = (BIGDIG)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 < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ + resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */ + } + return ss; +} +#endif +SCM number2string(x, radix) + SCM x, radix; +{ + if UNBNDP(radix) radix=MAKINUM(10L); + else ASSERT(INUMP(radix), radix, ARG2, s_number2string); +#ifdef FLOATS + if NINUMP(x) { + char num_buf[FLOBUFLEN]; +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return big2str(x, (unsigned int)INUM(radix)); +# ifndef RECKLESS + if (!(INEXP(x))) + badx: wta(x, (char *)ARG1, s_number2string); +# endif +# else + ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_number2string); +# endif + return makfromstr(num_buf, iflo2str(x, num_buf)); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_number2string); + return big2str(x, (unsigned int)INUM(radix)); + } +# else + ASSERT(INUMP(x), x, ARG1, s_number2string); +# endif +#endif + { + char num_buf[INTBUFLEN]; + return makfromstr(num_buf, iint2str(INUM(x), (int)INUM(radix), num_buf)); + } +} +/* These print routines are stubbed here so that repl.c doesn't need + FLOATS or BIGDIGs conditionals */ +int floprint(sexp, port, writing) + SCM sexp; + SCM port; + int writing; +{ +#ifdef FLOATS + char num_buf[FLOBUFLEN]; + lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port); +#else + ipruk("float", sexp, port); +#endif + return !0; +} +int bigprint(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ +#ifdef BIGDIG + exp = big2str(exp, (unsigned int)10); + lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port); +#else + ipruk("bignum", exp, port); +#endif + return !0; +} +/*** END nums->strs ***/ + +/*** STRINGS -> NUMBERS ***/ +#ifdef BIGDIG +SCM istr2int(str, len, radix) + char *str; + long len; + register long radix; +{ + sizet j; + register sizet k, blen = 1; + sizet i = 0; + int c; + SCM res; + register BIGDIG *ds; + register unsigned long t2; + + if (0 >= len) return BOOL_F; /* zero length */ + if (10==radix) j = 1+(84*len)/(BITSPERDIG*25); + else j = (8 < radix) ? 1+(4*len)/BITSPERDIG : 1+(3*len)/BITSPERDIG; + switch (str[0]) { /* leading sign */ + case '-': + case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */ + } + res = mkbig(j, '-'==str[0]); + ds = 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 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++] = BIGLO(t2); + t2 = BIGDN(t2); + } + ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum"); + if (t2) {blen++; goto moretodo;} + break; + default: + return BOOL_F; /* not a digit */ + } + } while (i < len); + if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM)) + if INUMP(res = big2inum(res, blen)) return res; + if (j==blen) return res; + return adjbig(res, blen); +} +#else +SCM istr2int(str, len, radix) + register char *str; + long len; + register long radix; +{ + register long n = 0, ln; + register int c; + register int i = 0; + int lead_neg = 0; + if (0 >= len) return BOOL_F; /* zero length */ + switch (*str) { /* leading sign */ + case '-': lead_neg = 1; + case '+': if (++i==len) return 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 BOOL_F; /* bad digit for radix */ + ln = n; + n = n * radix - c; + /* Negation is a workaround for HP700 cc bug */ + if (n > ln || (-n > -MOST_NEGATIVE_FIXNUM)) goto ovfl; + break; + default: + return BOOL_F; /* not a digit */ + } + } while (i < len); + if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl; + return MAKINUM(n); + ovfl: /* overflow scheme integer */ + return BOOL_F; +} +#endif + +#ifdef FLOATS +SCM istr2flo(str, len, radix) + register char *str; + register long len; + register 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 BOOL_F; /* zero 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 BOOL_F; /* bad if lone `+' or `-' */ + + if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */ + if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */ + if (++i < len) return BOOL_F; /* `i' not last character */ + return 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 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 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 BOOL_F; + tmp = tmp * radix + c; + break; + default: + goto out2; + } + } + out2: + if (tmp==0.0) return 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 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 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 BOOL_F; /* only in radix 10 */ + if (++i==len) return BOOL_F; /* bad exponent */ + switch (str[i]) { + case '-': expsgn=(-1); + case '+': if (++i==len) return BOOL_F; /* bad exponent */ + } + if (str[i] < '0' || str[i] > '9') return BOOL_F; /* bad exponent */ + do { + switch (c = str[i]) { + case DIGITS: + expon = expon*10 + c-'0'; + if (expon > MAXEXP) return 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 makdbl(res, 0.0); + + if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */ + if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */ + if (++i < len) return BOOL_F; /* `i' not last character */ + return 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 angle */ + second = istr2flo(&str[i], (long)(len-i), radix); + if (!(INEXP(second))) return BOOL_F; /* not `real' */ + if (CPLXP(second)) return BOOL_F; /* not `real' */ + tmp = REALPART(second); + return makdbl(res*cos(tmp), res*sin(tmp)); + } + default: return BOOL_F; + } + + /* at this point, last char must be `i' */ + if (str[len-1] != 'i' && str[len-1] != 'I') return BOOL_F; + /* handles `x+i' and `x-i' */ + if (i==(len-1)) return makdbl(res, lead_sgn); + /* get a `ureal' for complex part */ + second = istr2flo(&str[i], (long)((len-i)-1), radix); + if (!(INEXP(second))) return BOOL_F; /* not `ureal' */ + if (CPLXP(second)) return BOOL_F; /* not `ureal' */ + tmp = REALPART(second); + if (tmp < 0.0) return BOOL_F; /* not `ureal' */ + return makdbl(res, (lead_sgn*tmp)); +} +#endif /* FLOATS */ + + +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 BOOL_F; + + while ((len-i) >= 2 && str[i]=='#' && ++i) + switch (str[i++]) { + case 'b': case 'B': if (rx_p++) return BOOL_F; radix = 2; break; + case 'o': case 'O': if (rx_p++) return BOOL_F; radix = 8; break; + case 'd': case 'D': if (rx_p++) return BOOL_F; radix = 10; break; + case 'x': case 'X': if (rx_p++) return BOOL_F; radix = 16; break; + case 'i': case 'I': if (ex_p++) return BOOL_F; ex = 2; break; + case 'e': case 'E': if (ex_p++) return BOOL_F; ex = 1; break; + default: return BOOL_F; + } + + switch (ex) { + case 1: + return istr2int(&str[i], len-i, radix); + case 0: + res = istr2int(&str[i], len-i, radix); + if NFALSEP(res) return res; +#ifdef FLOATS + case 2: return istr2flo(&str[i], len-i, radix); +#endif + } + return BOOL_F; +} + + +SCM string2number(str, radix) + SCM str, radix; +{ + if UNBNDP(radix) radix=MAKINUM(10L); + else ASSERT(INUMP(radix), radix, ARG2, s_str2number); + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2number); + return istring2number(CHARS(str), LENGTH(str), INUM(radix)); +} +/*** END strs->nums ***/ + +#ifdef FLOATS +SCM makdbl (x, y) + double x, y; +{ + SCM z; + if ((y==0.0) && (x==0.0)) return flo0; + NEWCELL(z); + DEFER_INTS; + if (y==0.0) { +# ifdef SINGLES + float fx; +# ifndef SINGLESONLY + if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x)) +# endif + { + CAR(z) = tc_flo; + FLO(z) = x; + ALLOW_INTS; + return z; + } +# endif /* def SINGLES */ + CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real"); + CAR(z) = tc_dblr; + } + else { + CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex"); + CAR(z) = tc_dblc; + IMAG(z) = y; + } + REAL(z) = x; + ALLOW_INTS; + return z; +} + +SCM eqv(x, y) + SCM x, y; +{ + if (x==y) return BOOL_T; + if IMP(x) return BOOL_F; + if IMP(y) return BOOL_F; + /* this ensures that types and length are the same. */ + if (CAR(x) != CAR(y)) return BOOL_F; + if NUMP(x) { +# ifdef BIGDIG + if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; +# endif + if (REALPART(x) != REALPART(y)) return BOOL_F; + if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F; + return BOOL_T; + } + return BOOL_F; +} +SCM memv(x, lst) /* m.borza 12.2.91 */ +SCM x, lst; +{ + for(;NIMP(lst);lst = CDR(lst)) { + ASRTGO(CONSP(lst), badlst); + if NFALSEP(eqv(CAR(lst), x)) return lst; + } +# ifndef RECKLESS + if (!(NULLP(lst))) + badlst: wta(lst, (char *)ARG2, s_memv); +# endif + return BOOL_F; +} +SCM assv(x, alist) /* m.borza 12.2.91 */ +SCM x, alist; +{ + SCM tmp; + for(;NIMP(alist);alist = CDR(alist)) { + ASRTGO(CONSP(alist), badlst); + tmp = CAR(alist); + ASRTGO(NIMP(tmp) && CONSP(tmp), badlst); + if NFALSEP(eqv(CAR(tmp), x)) return tmp; + } +# ifndef RECKLESS + if (!(NULLP(alist))) + badlst: wta(alist, (char *)ARG2, s_assv); +# endif + return BOOL_F; +} +#endif /* FLOATS */ + +SCM list_tail(lst, k) + SCM lst, k; +{ + register long i; + ASSERT(INUMP(k), k, ARG2, s_list_tail); + i = INUM(k); + while (i-- > 0) { + ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail); + lst = CDR(lst); + } + return lst; +} + +SCM string2list(str) + SCM str; +{ + long i; + SCM res = EOL; + unsigned char *src; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2list); + src = UCHARS(str); + for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res); + return res; +} +SCM string_copy(str) + SCM str; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy); + return makfromstr(CHARS(str), (sizet)LENGTH(str)); +} +SCM string_fill(str, chr) + SCM str, chr; +{ + register char *dst, c; + register long k; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill); + ASSERT(ICHRP(chr), chr, ARG2, s_st_fill); + c = ICHR(chr); + dst = CHARS(str); + for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c; + return UNSPECIFIED; +} +SCM vector2list(v) + SCM v; +{ + SCM res = EOL; + long i; + SCM *data; + ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list); + data = VELTS(v); + for(i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res); + return res; +} +SCM vector_fill(v, fill) + SCM v, fill; +{ + register long i; + register SCM *data; + ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill); + data = VELTS(v); + for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill; + return UNSPECIFIED; +} +static SCM vector_equal(x, y) + SCM x, y; +{ + long i; + for(i = LENGTH(x)-1;i >= 0;i--) + if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F; + return BOOL_T; +} +SCM bigequal(x, y) + SCM x, y; +{ +#ifdef BIGDIG + if (0==bigcomp(x, y)) return BOOL_T; +#endif + return BOOL_F; +} +SCM floequal(x, y) + SCM x, y; +{ +#ifdef FLOATS + if (REALPART(x) != REALPART(y)) return BOOL_F; + if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T; +#endif + return BOOL_F; +} +SCM equal(x, y) + SCM x, y; +{ + CHECK_STACK; + tailrecurse: POLL; + if (x==y) return BOOL_T; + if IMP(x) return BOOL_F; + if IMP(y) return BOOL_F; + if (CONSP(x) && CONSP(y)) { + if FALSEP(equal(CAR(x), CAR(y))) return BOOL_F; + x = CDR(x); + y = CDR(y); + goto tailrecurse; + } + /* this ensures that types and length are the same. */ + if (CAR(x) != CAR(y)) return BOOL_F; + switch (TYP7(x)) { + default: return BOOL_F; + case tc7_string: return st_equal(x, y); + case tc7_vector: return vector_equal(x, y); + case tc7_smob: { + int i = SMOBNUM(x); + if (!(i < numsmob)) return BOOL_F; + if (smobs[i].equalp) return (smobs[i].equalp)(x, y); + else return BOOL_F; + } + case tc7_bvect: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_cvect: case tc7_dvect: { + SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; + if (pred) return (*pred)(x, y); + else return BOOL_F; + } + } + return BOOL_F; +} + +SCM numberp(x) + SCM x; +{ + if INUMP(x) return BOOL_T; +#ifdef FLOATS + if (NIMP(x) && NUMP(x)) return BOOL_T; +#else +# ifdef BIGDIG + if (NIMP(x) && NUMP(x)) return BOOL_T; +# endif +#endif + return BOOL_F; +} +#ifdef FLOATS +SCM realp(x) + SCM x; +{ + if INUMP(x) return BOOL_T; + if IMP(x) return BOOL_F; + if REALP(x) return BOOL_T; +# ifdef BIGDIG + if BIGP(x) return BOOL_T; +# endif + return BOOL_F; +} +SCM intp(x) + SCM x; +{ + double r; + if INUMP(x) return BOOL_T; + if IMP(x) return BOOL_F; +# ifdef BIGDIG + if BIGP(x) return BOOL_T; +# endif + if (!INEXP(x)) return BOOL_F; + if CPLXP(x) return BOOL_F; + r = REALPART(x); + if (r==floor(r)) return BOOL_T; + return BOOL_F; +} +#endif /* FLOATS */ + +SCM inexactp(x) + SCM x; +{ +#ifdef FLOATS + if (NIMP(x) && INEXP(x)) return BOOL_T; +#endif + return BOOL_F; +} +SCM eqp(x, y) + SCM x, y; +{ +#ifdef FLOATS + SCM t; + if NINUMP(x) { +# ifdef BIGDIG +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_eqp); +# endif + if BIGP(x) { + if INUMP(y) return BOOL_F; + ASRTGO(NIMP(y), bady); + if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + ASRTGO(INEXP(y), bady); + bigreal: + return (REALP(y) && (big2dbl(x)==REALPART(y))) ? BOOL_T : BOOL_F; + } + ASRTGO(INEXP(x), badx); +# else + ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp); +# endif + if INUMP(y) {t = x; x = y; y = t; goto realint;} +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + if (REALPART(x) != REALPART(y)) return BOOL_F; + if CPLXP(x) + return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F; + return CPLXP(y) ? BOOL_F : BOOL_T; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BOOL_F; +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif +# endif + realint: + return (REALP(y) && (((double)INUM(x))==REALPART(y))) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_eqp); + if INUMP(y) return BOOL_F; + ASRTGO(NIMP(y) && BIGP(y), bady); + return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif + return BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_eqp); + ASSERT(INUMP(y), y, ARG2, s_eqp); +# endif +#endif + return ((long)x==(long)y) ? BOOL_T : BOOL_F; +} +SCM lessp(x, y) + SCM x, y; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_lessp); +# endif + if BIGP(x) { + if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + ASRTGO(NIMP(y), bady); + if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; + ASRTGO(REALP(y), bady); + return (big2dbl(x) < REALPART(y)) ? BOOL_T : BOOL_F; + } + ASRTGO(REALP(x), badx); +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp); +# endif + if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) < big2dbl(y)) ? BOOL_T : BOOL_F; + ASRTGO(REALP(y), bady); +# else + ASRTGO(NIMP(y) && REALP(y), bady); +# endif + return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_lessp); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + bady: wta(y, (char *)ARG2, s_lessp); +# endif +# endif + return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_lessp); + if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + ASRTGO(NIMP(y) && BIGP(y), bady); + return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_lessp); +# endif + return BIGSIGN(y) ? BOOL_F : BOOL_T; + } +# else + ASSERT(INUMP(x), x, ARG1, s_lessp); + ASSERT(INUMP(y), y, ARG2, s_lessp); +# endif +#endif + return ((long)x < (long)y) ? BOOL_T : BOOL_F; +} +SCM greaterp(x, y) + SCM x, y; +{ + return lessp(y, x); +} +SCM leqp(x, y) + SCM x, y; +{ + return BOOL_NOT(lessp(y, x)); +} +SCM greqp(x, y) + SCM x, y; +{ + return BOOL_NOT(lessp(x, y)); +} +SCM zerop(z) + SCM z; +{ +#ifdef FLOATS + if NINUMP(z) { +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return BOOL_F; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_zerop); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_zerop); +# endif + return (z==flo0) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(z) { + ASSERT(NIMP(z) && BIGP(z), z, ARG1, s_zerop); + return BOOL_F; + } +# else + ASSERT(INUMP(z), z, ARG1, s_zerop); +# endif +#endif + return (z==INUM0) ? BOOL_T: BOOL_F; +} +SCM positivep(x) + SCM x; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; +# ifndef RECKLESS + if (!(REALP(x))) + badx: wta(x, (char *)ARG1, s_positivep); +# endif +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_positivep); +# endif + return (REALPART(x) > 0.0) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_positivep); + return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_positivep); +# endif +#endif + return (x > INUM0) ? BOOL_T : BOOL_F; +} +SCM negativep(x) + SCM x; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; +# ifndef RECKLESS + if (!(REALP(x))) + badx: wta(x, (char *)ARG1, s_negativep); +# endif +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_negativep); +# endif + return (REALPART(x) < 0.0) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_negativep); + return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_negativep); +# endif +#endif + return (x < INUM0) ? BOOL_T : BOOL_F; +} + +SCM lmax(x, y) + SCM x, y; +{ +#ifdef FLOATS + double z; +#endif + if UNBNDP(y) { +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_max); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) { + if INUMP(y) return BIGSIGN(x) ? y : x; + ASRTGO(NIMP(y), bady); + if BIGP(y) return (1==bigcomp(x, y)) ? y : x; + ASRTGO(REALP(y), bady); + z = big2dbl(x); + return (z < REALPART(y)) ? y : makdbl(z, 0.0); + } + ASRTGO(REALP(x), badx); +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_max); +# endif + if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) < (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + ASRTGO(REALP(y), bady); +# else + ASRTGO(NIMP(y) && REALP(y), bady); +# endif + return (REALPART(x) < REALPART(y)) ? y : x; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? x : y; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_max); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + bady: wta(y, (char *)ARG2, s_max); +# endif +# endif + return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_max); + if INUMP(y) return BIGSIGN(x) ? y : x; + ASRTGO(NIMP(y) && BIGP(y), bady); + return (1==bigcomp(x, y)) ? y : x; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_max); +# endif + return BIGSIGN(y) ? x : y; + } +# else + ASSERT(INUMP(x), x, ARG1, s_max); + ASSERT(INUMP(y), y, ARG2, s_max); +# endif +#endif + return ((long)x < (long)y) ? y : x; +} + +SCM lmin(x, y) + SCM x, y; +{ +#ifdef FLOATS + double z; +#endif + if UNBNDP(y) { +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_min); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) { + if INUMP(y) return BIGSIGN(x) ? x : y; + ASRTGO(NIMP(y), bady); + if BIGP(y) return (-1==bigcomp(x, y)) ? y : x; + ASRTGO(REALP(y), bady); + z = big2dbl(x); + return (z > REALPART(y)) ? y : makdbl(z, 0.0); + } + ASRTGO(REALP(x), badx); +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_min); +# endif + if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) > (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + ASRTGO(REALP(y), bady); +# else + ASRTGO(NIMP(y) && REALP(y), bady); +# endif + return (REALPART(x) > REALPART(y)) ? y : x; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? y : x; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_min); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + bady: wta(y, (char *)ARG2, s_min); +# endif +# endif + return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_min); + if INUMP(y) return BIGSIGN(x) ? x : y; + ASRTGO(NIMP(y) && BIGP(y), bady); + return (-1==bigcomp(x, y)) ? y : x; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_min); +# endif + return BIGSIGN(y) ? y : x; + } +# else + ASSERT(INUMP(x), x, ARG1, s_min); + ASSERT(INUMP(y), y, ARG2, s_min); +# endif +#endif + return ((long)x > (long)y) ? y : x; +} + +SCM sum(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return INUM0; +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_sum); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { + SCM t; +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) { + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y), bady); + if BIGP(y) { + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); + } + ASRTGO(INEXP(y), bady); + bigreal: return makdbl(big2dbl(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0); + } + ASRTGO(INEXP(x), badx); +# else + ASRTGO(NIMP(x) && INEXP(x), badx); +# endif + if INUMP(y) {t = x; x = y; y = t; goto intreal;} +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) {t = x; x = y; y = t; goto bigreal;} +# ifndef RECKLESS + else if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_sum); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_sum); +# endif +# endif + { double i = 0.0; + if CPLXP(x) i = IMAG(x); + if CPLXP(y) i += IMAG(y); + return makdbl(REALPART(x)+REALPART(y), i); } + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# endif + } + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + intreal: return makdbl(INUM(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_sum); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# endif + } + } +# else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_sum); +# endif +#endif + x = INUM(x)+INUM(y); + if FIXABLE(x) return MAKINUM(x); +#ifdef BIGDIG + return long2big(x); +#else +# ifdef FLOATS + return makdbl((double)x, 0.0); +# else + wta(y, (char *)OVFLOW, s_sum); +# endif +#endif +} + +SCM difference(x, y) + SCM x, y; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_difference); +# endif + if UNBNDP(y) { +# ifdef BIGDIG + if BIGP(x) { + x = copybig(x, !BIGSIGN(x)); + return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? + big2inum(x, NUMDIGS(x)) : x; + } +# endif + ASRTGO(INEXP(x), badx); + return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0); + } + if INUMP(y) return sum(x, MAKINUM(-INUM(y))); +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(x) { + if BIGP(y) return (NUMDIGS(x) < NUMDIGS(y)) ? + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + ASRTGO(INEXP(y), bady); + return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); + } + ASRTGO(INEXP(x), badx); + if BIGP(y) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0); + ASRTGO(INEXP(y), bady); +# else + ASRTGO(INEXP(x), badx); + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + if CPLXP(x) + if CPLXP(y) + return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y)); + else + return makdbl(REAL(x)-REALPART(y), IMAG(x)); + return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); + } + if UNBNDP(y) {x = -INUM(x); goto checkx;} + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# endif + } +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_difference); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_difference); +# endif +# endif + return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference); + if UNBNDP(y) { + x = copybig(x, !BIGSIGN(x)); + return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? + big2inum(x, NUMDIGS(x)) : x; + } + if INUMP(y) { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(y)); + return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); +# endif + } + ASRTGO(NIMP(y) && BIGP(y), bady); + return (NUMDIGS(x) < NUMDIGS(y)) ? + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + } + if UNBNDP(y) {x = -INUM(x); goto checkx;} + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_difference); +# endif + { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# endif + } + } +# else + ASSERT(INUMP(x), x, ARG1, s_difference); + if UNBNDP(y) {x = -INUM(x); goto checkx;} + ASSERT(INUMP(y), y, ARG2, s_difference); +# endif +#endif + x = INUM(x)-INUM(y); + checkx: + if FIXABLE(x) return MAKINUM(x); +#ifdef BIGDIG + return long2big(x); +#else +# ifdef FLOATS + return makdbl((double)x, 0.0); +# else + wta(y, (char *)OVFLOW, s_difference); +# endif +#endif +} + +SCM product(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return MAKINUM(1L); +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_product); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { + SCM t; +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) { + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y), bady); + if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y)); + ASRTGO(INEXP(y), bady); + bigreal: { + double bg = big2dbl(x); + return makdbl(bg*REALPART(y), CPLXP(y)?bg*IMAG(y):0.0); } + } + ASRTGO(INEXP(x), badx); +# else + ASRTGO(NIMP(x) && INEXP(x), badx); +# endif + if INUMP(y) {t = x; x = y; y = t; goto intreal;} +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) {t = x; x = y; y = t; goto bigreal;} +# ifndef RECKLESS + else if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_product); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_product); +# endif +# endif + if CPLXP(x) + if CPLXP(y) + return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y), + REAL(x)*IMAG(y)+IMAG(x)*REAL(y)); + else + return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y)); + return makdbl(REALPART(x)*REALPART(y), + CPLXP(y)?REALPART(x)*IMAG(y):0.0); + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) { + intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; + { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); +# endif + } + } + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + intreal: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {SCM t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y)); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_product); +# endif + intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; + { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return mulbig(&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); +# endif + } + } +# else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_product); +# endif +#endif + { + long i, j, k; + i = INUM(x); + if (0==i) return x; + j = INUM(y); + k = i * j; + y = MAKINUM(k); + if (k != INUM(y) || k/i != j) +#ifdef BIGDIG + { int sgn = (i < 0) ^ (j < 0); +# ifndef DIGSTOOBIG + i = pseudolong(i); + j = pseudolong(j); + return mulbig((BIGDIG *)&i, DIGSPERLONG, + (BIGDIG *)&j, DIGSPERLONG, sgn); +# else /* DIGSTOOBIG */ + BIGDIG idigs[DIGSPERLONG]; + BIGDIG jdigs[DIGSPERLONG]; + longdigs(i, idigs); + longdigs(j, jdigs); + return mulbig(idigs, DIGSPERLONG, jdigs, DIGSPERLONG, sgn); +# endif + } +#else +# ifdef FLOATS + return makdbl(((double)i)*((double)j), 0.0); +# else + wta(y, (char *)OVFLOW, s_product); +# endif +#endif + return y; + } +} + +SCM divide(x, y) + SCM x, y; +{ +#ifdef FLOATS + double d, r, i, a; + if NINUMP(x) { +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_divide); +# endif + if UNBNDP(y) { +# ifdef BIGDIG + if BIGP(x) return makdbl(1.0/big2dbl(x), 0.0); +# endif + ASRTGO(INEXP(x), badx); + if REALP(x) return makdbl(1.0/REALPART(x), 0.0); + r = REAL(x); i = IMAG(x); d = r*r+i*i; + return makdbl(r/d, -i/d); + } +# ifdef BIGDIG + if BIGP(x) { + SCM z; + if INUMP(y) { + z = INUM(y); + ASSERT(z, y, OVFLOW, s_divide); + if (1==z) return x; + if (z < 0) z = -z; + if (z < BIGRAD) { + SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); + return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ? + makdbl(big2dbl(x)/INUM(y), 0.0) : normbig(w); + } +# ifndef DIGSTOOBIG + z = pseudolong(z); + z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3); +# else + { BIGDIG zdigs[DIGSPERLONG]; + longdigs(z, zdigs); + z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3);} +# endif + return z ? z : makdbl(big2dbl(x)/INUM(y), 0.0); + } + ASRTGO(NIMP(y), bady); + if BIGP(y) { + z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y), 3); + return z ? z : makdbl(big2dbl(x)/big2dbl(y), 0.0); + } + ASRTGO(INEXP(y), bady); + if REALP(y) return makdbl(big2dbl(x)/REALPART(y), 0.0); + a = big2dbl(x); + goto complex_div; + } +# endif + ASRTGO(INEXP(x), badx); + if INUMP(y) {d = INUM(y); goto basic_div;} +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) {d = big2dbl(y); goto basic_div;} + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + if REALP(y) { + d = REALPART(y); + basic_div: return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0); + } + a = REALPART(x); + if REALP(x) goto complex_div; + r = REAL(y); i = IMAG(y); d = r*r+i*i; + return makdbl((a*r+IMAG(x)*i)/d, (IMAG(x)*r-a*i)/d); + } + if UNBNDP(y) { + if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; + return makdbl(1.0/((double)INUM(x)), 0.0); + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return makdbl(INUM(x)/big2dbl(y), 0.0); +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif +# endif + if REALP(y) return makdbl(INUM(x)/REALPART(y), 0.0); + a = INUM(x); + complex_div: + r = REAL(y); i = IMAG(y); d = r*r+i*i; + return makdbl((a*r)/d, (-a*i)/d); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + SCM z; + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide); + if UNBNDP(y) goto ov; + if INUMP(y) { + z = INUM(y); + if (!z) goto ov; + if (1==z) return x; + if (z < 0) z = -z; + if (z < BIGRAD) { + SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); + if (divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z)) goto ov; + return w; + } +# ifndef DIGSTOOBIG + z = pseudolong(z); + z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3); +# else + { BIGDIG zdigs[DIGSPERLONG]; + longdigs(z, zdigs); + z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3);} +# endif + } else { + ASRTGO(NIMP(y) && BIGP(y), bady); + z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y), 3); + } + if (!z) goto ov; + return z; + } + if UNBNDP(y) { + if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; + goto ov; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif + goto ov; + } +# else + ASSERT(INUMP(x), x, ARG1, s_divide); + if UNBNDP(y) { + if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; + goto ov; + } + ASSERT(INUMP(y), y, ARG2, s_divide); +# endif +#endif + { + long z = INUM(y); + if ((0==z) || INUM(x)%z) goto ov; + z = INUM(x)/z; + if FIXABLE(z) return MAKINUM(z); +#ifdef BIGDIG + return long2big(z); +#endif +#ifdef FLOATS + ov: return makdbl(((double)INUM(x))/((double)INUM(y)), 0.0); +#else + ov: wta(x, (char *)OVFLOW, s_divide); +#endif + } +} + +#ifdef FLOATS +double lasinh(x) + double x; +{ + return log(x+sqrt(x*x+1)); +} + +double lacosh(x) + double x; +{ + return log(x+sqrt(x*x-1)); +} + +double latanh(x) + double x; +{ + return 0.5*log((1+x)/(1-x)); +} + +double ltrunc(x) + double x; +{ + if (x < 0.0) return -floor(-x); + return floor(x); +} +double round(x) + double x; +{ + double plus_half = x + 0.5; + double result = floor(plus_half); + /* Adjust so that the round is towards even. */ + return (plus_half==result && plus_half / 2 != floor(plus_half / 2)) + ? result - 1 : result; +} + +struct dpair {double x, y;}; + +void two_doubles(z1, z2, sstring, xy) + SCM z1, z2; + char *sstring; + struct dpair *xy; +{ + if INUMP(z1) xy->x = INUM(z1); + else { +# ifdef BIGDIG + ASRTGO(NIMP(z1), badz1); + if BIGP(z1) xy->x = big2dbl(z1); + else { +# ifndef RECKLESS + if (!(REALP(z1))) + badz1: wta(z1, (char *)ARG1, sstring); +# endif + xy->x = REALPART(z1);} +# else + {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring); + xy->x = REALPART(z1);} +# endif + } + if INUMP(z2) xy->y = INUM(z2); + else { +# ifdef BIGDIG + ASRTGO(NIMP(z2), badz2); + if BIGP(z2) xy->y = big2dbl(z2); + else { +# ifndef RECKLESS + if (!(REALP(z2))) + badz2: wta(z2, (char *)ARG2, sstring); +# endif + xy->y = REALPART(z2);} +# else + {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring); + xy->y = REALPART(z2);} +# endif + } +} + +SCM expt(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_expt, &xy); + return makdbl(pow(xy.x, xy.y), 0.0); +} +SCM latan2(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_atan2, &xy); + return makdbl(atan2(xy.x, xy.y), 0.0); +} +SCM makrect(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_makrect, &xy); + return makdbl(xy.x, xy.y); +} +SCM makpolar(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_makpolar, &xy); + return makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y)); +} + +SCM real_part(z) + SCM z; +{ + if NINUMP(z) { +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return z; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_real_part); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part); +# endif + if CPLXP(z) return makdbl(REAL(z), 0.0); + } + return z; +} +SCM imag_part(z) + SCM z; +{ + if INUMP(z) return INUM0; +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return INUM0; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_imag_part); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part); +# endif + if CPLXP(z) return makdbl(IMAG(z), 0.0); + return flo0; +} +SCM magnitude(z) + SCM z; +{ + if INUMP(z) return absval(z); +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return absval(z); +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_magnitude); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude); +# endif + if CPLXP(z) + { + double i = IMAG(z), r = REAL(z); + return makdbl(sqrt(i*i+r*r), 0.0); + } + return makdbl(fabs(REALPART(z)), 0.0); +} + +SCM angle(z) + SCM z; +{ + double x, y = 0.0; + if INUMP(z) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;} +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} +# ifndef RECKLESS + if (!(INEXP(z))) { + badz: wta(z, (char *)ARG1, s_angle);} +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle); +# endif + if REALP(z) {x = REALPART(z); goto do_angle;} + x = REAL(z); y = IMAG(z); +do_angle: + return makdbl(atan2(y, x), 0.0); +} + +double floident(z) + double z; +{ + return z; +} +SCM in2ex(z) + SCM z; +{ + if INUMP(z) return z; +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return z; +# ifndef RECKLESS + if (!(REALP(z))) + badz: wta(z, (char *)ARG1, s_in2ex); +# endif +# else + ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex); +# endif +# ifdef BIGDIG + { + double u = floor(REALPART(z)+0.5); + if ((u <= MOST_POSITIVE_FIXNUM) && (-u <= -MOST_NEGATIVE_FIXNUM)) { + /* Negation is a workaround for HP700 cc bug */ + SCM ans = MAKINUM((long)u); + if (INUM(ans)==(long)u) return ans; + } + ASRTGO(!IS_INF(u), badz); /* problem? */ + return dbl2big(u); + } +# else + return MAKINUM((long)floor(REALPART(z)+0.5)); +# endif +} +#else /* ~FLOATS */ +static char s_trunc[] = "truncate"; +SCM numident(x) + SCM x; +{ + ASSERT(INUMP(x), x, ARG1, s_trunc); + return x; +} +#endif /* FLOATS */ + +#ifdef BIGDIG +# ifdef FLOATS +SCM dbl2big(d) + double d; /* must be integer */ +{ + sizet i = 0; + long c; + BIGDIG *digits; + SCM ans; + double u = (d < 0)?-d:d; + while (0 != floor(u)) {u /= BIGRAD;i++;} + ans = mkbig(i, d < 0); + digits = BDIGITS(ans); + while (i--) { + u *= BIGRAD; + c = floor(u); + u -= c; + digits[i] = c; + } + ASSERT(0==u, INUM0, OVFLOW, "dbl2big"); + return ans; +} +double big2dbl(b) + SCM b; +{ + double ans = 0.0; + sizet i = NUMDIGS(b); + BIGDIG *digits = BDIGITS(b); + while (i--) ans = digits[i] + BIGRAD*ans; + if (tc16_bigneg==TYP16(b)) return -ans; + return ans; +} +# endif +#endif + +unsigned long hasher(obj, n, d) + SCM obj; + unsigned long n; + sizet d; +{ + switch (7 & (int) obj) { + case 2: case 6: /* INUMP(obj) */ + return INUM(obj) % n; + case 4: + if ICHRP(obj) + return (unsigned)(downcase[ICHR(obj)]) % n; + switch ((int) obj) { +#ifndef SICP + case (int) EOL: d = 256; break; +#endif + case (int) BOOL_T: d = 257; break; + case (int) BOOL_F: d = 258; break; + case (int) 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 TYP7(obj) { + default: return 263 % n; + case tc7_smob: + switch TYP16(obj) { + case tcs_bignums: + bighash: return INUM(modulo(obj, MAKINUM(n))); + default: return 263 % n; +#ifdef FLOATS + case tc16_flo: + if REALP(obj) { + double r = REALPART(obj); + if (floor(r)==r) { + obj = in2ex(obj); + if IMP(obj) return INUM(obj) % n; + goto bighash; + } + } + obj = number2string(obj, MAKINUM(10)); +#endif + } + case tcs_symbols: case tc7_string: + return strhash(UCHARS(obj), (sizet) LENGTH(obj), n); + case tc7_vector: { + sizet len = LENGTH(obj); + SCM *data = VELTS(obj); + if (len>5) { + sizet i = d/2; + unsigned long h = 1; + while (i--) h = ((h<<8) + (hasher(data[h % len], n, 2))) % n; + return h; + } + else { + sizet i = len; + unsigned long h = (n)-1; + while (i--) h = ((h<<8) + (hasher(data[i], n, d/len))) % n; + return h; + } + } + case tcs_cons_imcar: case tcs_cons_nimcar: + if (d) return (hasher(CAR(obj), n, d/2)+hasher(CDR(obj), n, d/2)) % n; + else return 1; + case tc7_port: + return ((RDNG & CAR(obj)) ? 260 : 261) % n; + case tcs_closures: case tc7_contin: case tcs_subrs: + return 262 % n; + } + } +} + +static char s_hashv[] = "hashv", s_hashq[] = "hashq"; +extern char s_obunhash[]; +#define s_hash (&s_obunhash[9]) + +SCM hash(obj, n) + SCM obj; + SCM n; +{ + ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash); + return MAKINUM(hasher(obj, INUM(n), 10)); +} + +SCM hashv(obj, n) + SCM obj; + SCM n; +{ + ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashv); + if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n)); + if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10)); + else return MAKINUM(obj % INUM(n)); +} + +SCM hashq(obj, n) + SCM obj; + SCM n; +{ + ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq); + return MAKINUM((((unsigned) obj) >> 1) % INUM(n)); +} + +static iproc subr1s[] = { + {"number?", numberp}, + {"complex?", numberp}, + {s_inexactp, inexactp}, +#ifdef FLOATS + {"real?", realp}, + {"rational?", realp}, + {"integer?", intp}, + {s_real_part, real_part}, + {s_imag_part, imag_part}, + {s_magnitude, magnitude}, + {s_angle, angle}, + {s_in2ex, in2ex}, +#else + {"real?", numberp}, + {"rational?", numberp}, + {"integer?", exactp}, + {"floor", numident}, + {"ceiling", numident}, + {s_trunc, numident}, + {"round", numident}, +#endif + {s_zerop, zerop}, + {s_positivep, positivep}, + {s_negativep, negativep}, + {s_str2list, string2list}, + {"list->string", string}, + {s_st_copy, string_copy}, + {"list->vector", vector}, + {s_vect2list, vector2list}, + {0, 0}}; + +static iproc asubrs[] = { + {s_difference, difference}, + {s_divide, divide}, + {s_max, lmax}, + {s_min, lmin}, + {s_sum, sum}, + {s_product, product}, + {0, 0}}; + +static iproc subr2s[] = { +#ifdef FLOATS + {s_makrect, makrect}, + {s_makpolar, makpolar}, + {s_memv, memv}, + {s_assv, assv}, + {s_atan2, latan2}, + {s_expt, expt}, +#else + {"memv", memq}, + {"assv", assq}, +#endif + {s_list_tail, list_tail}, + {s_ve_fill, vector_fill}, + {s_st_fill, string_fill}, + {s_hash, hash}, + {s_hashv, hashv}, + {s_hashq, hashq}, + {0, 0}}; + +static iproc subr2os[] = { + {s_str2number, string2number}, + {s_number2string, number2string}, + {0, 0}}; + +static iproc rpsubrs[] = { +#ifdef FLOATS + {"eqv?", eqv}, +#else + {"eqv?", eq}, +#endif + {s_eqp, eqp}, + {s_lessp, lessp}, + {s_grp, greaterp}, + {s_leqp, leqp}, + {s_greqp, greqp}, + {0, 0}}; + +#ifdef FLOATS +static dblproc cxrs[] = { + {"floor", floor}, + {"ceiling", ceil}, + {"truncate", ltrunc}, + {"round", round}, + {"$sqrt", sqrt}, + {"$abs", fabs}, + {"$exp", exp}, + {"$log", log}, + {"$sin", sin}, + {"$cos", cos}, + {"$tan", tan}, + {"$asin", asin}, + {"$acos", acos}, + {"$atan", atan}, + {"$sinh", sinh}, + {"$cosh", cosh}, + {"$tanh", tanh}, + {"$asinh", lasinh}, + {"$acosh", lacosh}, + {"$atanh", latanh}, + {"exact->inexact", floident}, + {0, 0}}; +#endif + +#ifdef FLOATS +# ifndef DBL_DIG +static void add1(f, fsum) + double f, *fsum; +{ + *fsum = f + 1.0; +} +# endif +#endif + +void init_scl() +{ + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(asubrs, tc7_asubr); + init_iprocs(rpsubrs, tc7_rpsubr); +#ifdef SICP + add_feature("sicp"); +#endif +#ifdef FLOATS + init_iprocs((iproc *)cxrs, tc7_cxr); + NEWCELL(flo0); +# ifdef SINGLES + CAR(flo0) = tc_flo; + FLO(flo0) = 0.0; +# else + CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real"); + REAL(flo0) = 0.0; + CAR(flo0) = tc_dblr; +# endif +# ifdef DBL_DIG + 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 (++dblprec > 20) break; + add1(f, &fsum); + } + dblprec = dblprec-1; + } +# endif /* DBL_DIG */ +#endif +} @@ -0,0 +1,335 @@ +.\" dummy line +.TH SCM "Jan 9 1995" +.UC 4 +.SH NAME +scm \- a Scheme Language Interpreter +.SH SYNOPSIS +.B scm +[-a +.I kbytes +] +[-ibvqmu] +[-p +.I number +] +[-c +.I expression +] +[-e +.I expression +] +[-f +.I filename +] +[-l +.I filename +] +[-d +.I filename +] +[-r +.I feature +] +[-- | - | -s] +[filename] [arguments ...] +.br +.sp 0.3 +.SH DESCRIPTION +.I Scm +is a Scheme interpreter. +.PP +Upon startup +.I scm +loads the file specified by by the environment variable SCM_INIT_PATH +or by the parameter IMPLINIT in the makefile (or scmfig.h) if +SCM_INIT_PATH is not defined. The makefiles attempt to set IMPLINIT +to "Init.scm" in the source directory. + +Unless the option +.I -no-init-file +occurs in the command line, "Init.scm" checks to see if there is file +"ScmInit.scm" in the path specified by the environment variable HOME +(or in the current directory if HOME is undefined). If it finds such +a file it is loaded. + +"Init.scm" then looks for command input from one of three sources: +From an option on the command line, from a file named on the command +line, or from standard input. + +.SH OPTIONS +The options are processed in the order specified on the command line. +.TP 5 +.BI -a kbytes +specifies that +.I scm +should allocate an initial heapsize of +.I kbytes. +This option, if present, must be the first on the command line. +.TP +.BI -no-init-file +Inhibits the loading of "ScmInit.scm" as described above. +.TP +.BI -e expression +.TP +.BI -c expression +specifies that the scheme expression +.I expression +is to be evaluated. These options are inspired by +.I perl +and +.I sh +respectively. +On Amiga systems the entire option and argument need to be enclosed in +qoutes. For instance "-e(newline)". +.TP +.BI -r feature +requires +.I feature. +This will load a file from SLIB if that +.I feature +is not already supported. If +.I feature +is 2, 3, 4, or 5 +.I scm +will require the features neccessary to support R2RS, R3RS, R4RS, or +proposed R5RS, respectively. +.TP +.BI -l filename +.TP +.BI -f filename +loads +.I filename. +.I Scm +will load the first (unoptioned) file named on the command line if no +-c, -e, -f, -l, or -s option preceeds it. +.TP +.BI -d filename +opens (read-only) the extended relational database +.I filename. +If +.I filename +contains initialization code, it will be run when the database is +opened. +.TP +.BI -p level +sets the prolixity (verboseness) to +.I level. +This is the same as the +.I scm +command (verobse +.I level +). +.TP +.B -v +(verbose mode) specifies that +.I scm +will print prompts, evaluation times, notice of loading files, and +garbage collection statistics. This is the same as +.I -p3. +.TP +.B -q +(quiet mode) specifies that +.I scm +will print no extra information. This is the same as +.I -p0. +.TP +.B -m +specifies that subsequent loads, evaluations, and user interactions +will be with R4RS macro capability. To use a specific R4RS macro +implementation from SLIB (instead of SLIB's default) put +.I -r macropackage +before +.I -m +on the command line. +.TP +.B -u +specifies that subsequent loads, evaluations, and user interactions +will be without R4RS macro capability. R4RS macro capability can be +restored by a subsequent +.I -m +on the command line or from Scheme code. +.TP +.B -i +specifies that +.I scm +should run interactively. That means that +.I scm +will not terminate until the +.I (quit) +or +.I (exit) +command is given, even if there are errors. It also sets the +prolixity level to 2 if it is less than 2. This will print +prompts, evaluation times, and notice of loading files. The prolixity +level can be set by subsequent options. If +.I scm +is started from a tty, it will assume that it should be interactive +unless given a subsequent +.I -b +option. +.TP +.B -b +specifies that +.I scm +should run non-interactively. That means that +.I scm +will terminate after processing the command line or if there are +errors. +.TP +.B -s +specifies, by analogy with +.I sh, +that further options are to be treated as program aguments. +.TP +.BI - +.BI -- +specifies that there are no more options on the command line. +.SH ENVIRONMENT VARIABLES +.TP 5 +.B SCM_INIT_PATH +is the pathname where +.I scm +will look for its initialization code. The default is the file +"Init.scm" in the source directory. +.TP +.B SCHEME_LIBRARY_PATH +is the SLIB Scheme library directory. +.TP +.B HOME +is the directory where "Init.scm" will look for the user +initialization file "ScmInit.scm". +.SH SCHEME VARIABLES +.TP 5 +.B *argv* +contains the list of arguments to the program. +.I *argv* +can change during argument processing. This list is +suitable for use as an argument to SLIB +.I getopt. +.TP +.B *R4RS-macro* +controls whether loading and interaction support R4RS macros. Define +this in "ScmInit.scm" or files specified on the command line. This +can be overridden by subsequent -m and -u options. +.TP +.B *interactive* +controls interactivity as explained for the -i and -b options. Define +this in "ScmInit.scm" or files specified on the command line. This +can be overridden by subsequent -i and -b options. +.SH EXAMPLES +.ne 5 +.TP 5 +% scm foo.scm arg1 arg2 arg3 +.br +Load and execute the contents of foo.scm. Parameters +arg1 arg2 and arg3 are stored in the global list *argv*. +.TP +% scm -f foo.scm arg1 arg2 arg3 +.br +The same. +.TP +% scm -s foo.scm arg1 arg2 +.br +Set *argv* to ("foo.scm" "arg1" "arg2") and enter interactive session. +.TP +% scm -e '(display (list-ref *argv* *optind*))' bar +.br +Print ``bar'' +.TP +% scm -rpretty-print -r format -i +.br +Load pretty-print and format and enter interactive mode. +.TP +% scm -r5 +.br +Load dynamic-wind, values, and R4RS macros and enter interactive (with +macros) mode. +.TP +% scm -r5 -r4 +.br +Like above but rev4-optional-procedures are also loaded. +.SH FEATURES +.PP +Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, +Unix and similar systems. Support for ASCII and EBCDIC character +sets. +.PP +Conforms to Revised^4 Report on the Algorithmic Language Scheme +and the IEEE P1178 specification. +.PP +Support for SICP, R2RS, R3RS, and (proposed) R5RS scheme code. +.PP +Many Common Lisp functions: +logand, logor, logxor, lognot, ash, logcount, integer-length, +bit-extract, defmacro, macroexpand, macroexpand1, gentemp, +defvar, force-output, software-type, get-decoded-time, +get-internal-run-time, get-internal-real-time, delete-file, +rename-file, copy-tree, acons, and eval. +.PP +Char-code-limit, most-positive-fixnum, most-negative-fixnum, +and internal-time-units-per-second constants. *Features* and +*load-pathname* variables. +.PP +Arrays and bit-vectors. String ports and software emulation ports. +I/O extensions providing most of ANSI C and POSIX.1 facilities. +.PP +User definable responses to interrupts and errors, +Process-syncronization primitives, String regular expression matching, +and the CURSES screen management package. +.PP +Available add-on packages including an interactive debugger, database, +X-window graphics, BGI graphics, Motif, and Open-Windows packages. +.PP +A compiler (HOBBIT, available separately) and dynamic linking of +compiled modules. +.PP +Setable levels of monitoring and timing information printed +interactively (the `verbose' function). Restart, quit, and exec. +.SH FILES +.TP +code.doc +.br +Documentation on the internal representation and how to extend or +include scm in other programs. +.TP +scm.texi +.br +Documentation of SCM in Texinfo format. +.SH AUTHOR +Aubrey Jaffer +.br +(jaffer@ai.mit.edu) +.SH BUGS +.SH SEE ALSO +The Scheme specifications for details on specific procedures +(ftp-swiss.ai.mit.edu:archive/scheme-reports/) or +.PP +IEEE Std 1178-1990, +.br +IEEE Standard for the Scheme Programming Language, +.br +Institute of Electrical and Electronic Engineers, Inc., +.br +New York, NY, 1991 +.PP +Brian Harvey and Matthew Wright +.br +Simply Scheme: Introducing Computer Science_ +.br +MIT Press, 1994 +ISBN 0-262-08226-8 +.PP +R. Kent Dybvig, The Scheme Programming Language, +.br +Prentice-Hall Inc, Englewood Cliffs, New Jersey 07632, USA +.PP +H. Abelson, G. J. Sussman, and J. Sussman, +.br +Structure and Interpretation of Computer Programs, +.br +The MIT Press, Cambridge, Massachusetts, USA +.PP +Enhancements in +.I scm +not in the standards are detailed in MANUAL in the source directory. + @@ -0,0 +1,940 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "scm.c" top level and interrupt code. + Author: Aubrey Jaffer */ + +#include <signal.h> +#include "scm.h" +#include "patchlvl.h" + +#ifdef __IBMC__ +# include <io.h> +#endif + +#ifndef STDC_HEADERS + int alarm P((unsigned int)); + int pause P((void)); + unsigned int sleep P((unsigned int seconds)); + char *getenv P((const char *name)); + int system P((const char *)); +#endif +#ifdef hpux +# define const /**/ +#endif + +void final_repl P((void)); +void init_dynl P((void)); +void init_eval P((void)); +void init_features P((void)); +void init_io P((void)); +void init_ioext P((void)); +void init_repl P((int iverbose)); +void init_sc2 P((void)); +void init_scl P((void)); +void init_signals P((void)); +void init_subrs P((void)); +void init_tables P((void)); +void init_time P((void)); +void init_types P((void)); +void init_unif P((void)); +void init_ramap P((void)); + +void init_banner() +{ + fputs("SCM version ", stderr); + fputs(SCMVERSION, stderr); + fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 \ +Free Software Foundation.\n\ +SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\ +This is free software, and you are welcome to redistribute it\n\ +under certain conditions; type `(terms)' for details.\n", stderr); +} + +SCM scm_init_extensions() +{ +#ifdef COMPILED_INITS + COMPILED_INITS; /* initialize statically linked add-ons */ +#endif + return UNSPECIFIED; +} + +#if (__TURBOC__==1) +# define signal ssignal /* Needed for TURBOC V1.0 */ +#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 + +#ifdef SIGHUP +static SIGRETTYPE hup_signal(sig) + int sig; +{ + signal(SIGHUP, hup_signal); + wta(UNDEFINED, (char *)HUP_SIGNAL, ""); +} +#endif +static SIGRETTYPE int_signal(sig) + int sig; +{ + sig = errno; + signal(SIGINT, int_signal); + if (ints_disabled) sig_deferred = 1; + else han_sig(); + errno = sig; +} + +/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */ + +#ifndef SIGFPE +# undef FLOATS +#endif + +#ifdef FLOATS +static SIGRETTYPE fpe_signal(sig) + int sig; +{ + signal(SIGFPE, fpe_signal); + wta(UNDEFINED, (char *)FPE_SIGNAL, ""); +} +#endif +#ifdef SIGBUS +static SIGRETTYPE bus_signal(sig) + int sig; +{ + signal(SIGBUS, bus_signal); + wta(UNDEFINED, (char *)BUS_SIGNAL, ""); +} +#endif +#ifdef SIGSEGV /* AMIGA lacks! */ +static SIGRETTYPE segv_signal(sig) + int sig; +{ + signal(SIGSEGV, segv_signal); + wta(UNDEFINED, (char *)SEGV_SIGNAL, ""); +} +#endif +#ifdef atarist +# undef SIGALRM /* only available via MiNT libs */ +#endif +#ifdef GO32 +# undef SIGALRM +#endif +#ifdef __HIGHC__ +# undef SIGALRM +#endif +#ifdef SIGALRM +static SIGRETTYPE alrm_signal(sig) + int sig; +{ + sig = errno; + signal(SIGALRM, alrm_signal); + if (ints_disabled) alrm_deferred = 1; + else han_alrm(); + errno = sig; +} +static char s_alarm[] = "alarm"; +SCM lalarm(i) + SCM i; +{ + unsigned int j; + ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm); + SYSCALL(j = alarm(INUM(i));); + return MAKINUM(j); +} +# ifndef AMIGA +SCM l_pause() +{ + pause(); + return UNSPECIFIED; +} +# endif +#endif /* SIGALRM */ + +#ifdef _WIN32 +# include <windows.h> +#endif +#ifndef AMIGA +# ifndef _Windows +static char s_sleep[] = "sleep"; +SCM l_sleep(i) + SCM i; +{ + unsigned int j = 0; + ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep); +# ifdef __HIGHC__ + SYSCALL(sleep(INUM(i));); +# else +# ifdef _WIN32 + Sleep(INUM(i)); +# else + SYSCALL(j = sleep(INUM(i));); +# endif + return MAKINUM(j); +} +# endif +# endif +#endif + +#ifndef _WIN32 +# ifndef GO32 +# ifndef sun +/* int raise P((int sig)); */ +static char s_raise[] = "raise"; +SCM l_raise(sig) + SCM sig; +{ + ASSERT(INUMP(sig), sig, ARG1, s_raise); +# ifdef vms + return MAKINUM(gsignal((int)INUM(sig))); +# else +# ifndef __TURBOC__ +# ifdef STDC_HEADERS + return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T; +# else + return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; +# endif +# else + return raise((int)INUM(sig)) ? BOOL_F : BOOL_T; +# endif +# endif +} +# endif +# endif +#endif +#ifdef TICKS +unsigned int tick_count = 0, ticken = 0; +SCM *loc_tick_signal; +void tick_signal() +{ + if (ticken && NIMP(*loc_tick_signal)) { + ticken = 0; + apply(*loc_tick_signal, EOL, EOL); + } +} +static char s_ticks[] = "ticks"; +SCM lticks(i) + SCM i; +{ + SCM j = ticken ? tick_count : 0; + if (!UNBNDP(i)) ticken = tick_count = INUM(i); + return MAKINUM(j); +} +#endif + +#ifdef SIGHUP +static SIGRETTYPE (*oldhup)(); +#endif +static SIGRETTYPE (*oldint)(); +#ifdef FLOATS +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 + +int dumped = 0; /* Is this an invocation of unexec exe? */ + +#ifdef SHORT_ALIGN +typedef short STACKITEM; +#else +typedef long STACKITEM; +#endif +/* See scm.h for definition of P */ +void init_storage P((STACKITEM *stack_start_ptr, long init_heap_size)); + +void init_scm( iverbose, buf0stdin, init_heap_size ) + int iverbose; + int buf0stdin; + long init_heap_size; +{ + STACKITEM i; + if (2 <= iverbose) init_banner(); + if (!dumped) { + init_types(); + init_tables(); + init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */ + if (buf0stdin) CAR(def_inp) |= BUF0; + init_features(); + init_subrs(); + init_io(); + init_scl(); + init_eval(); + init_time(); + init_repl( iverbose ); + init_unif(); + }} + +void init_signals() +{ + oldint = signal(SIGINT, int_signal); +#ifdef SIGHUP + oldhup = signal(SIGHUP, hup_signal); +#endif +#ifdef FLOATS + oldfpe = signal(SIGFPE, fpe_signal); +#endif +#ifdef SIGBUS + oldbus = signal(SIGBUS, bus_signal); +#endif +#ifdef SIGSEGV /* AMIGA lacks! */ + oldsegv = signal(SIGSEGV, segv_signal); +#endif +#ifdef SIGALRM + alarm(0); /* kill any pending ALRM interrupts */ + oldalrm = signal(SIGALRM, 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 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 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 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 unignore_signals() +{ + signal(SIGINT, int_signal); +#ifdef SIGHUP + signal(SIGHUP, hup_signal); +#endif +#ifdef FLOATS + signal(SIGFPE, fpe_signal); +#endif +#ifdef SIGBUS + signal(SIGBUS, bus_signal); +#endif +#ifdef SIGSEGV /* AMIGA lacks! */ + signal(SIGSEGV, segv_signal); +#endif +#ifdef SIGALRM + signal(SIGALRM, alrm_signal); +#endif +#ifdef ultrix + siginterrupt(SIGINT, 1); + siginterrupt(SIGALRM, 1); + siginterrupt(SIGHUP, 1); + siginterrupt(SIGPIPE, 1); +#endif /* ultrix */ +} + +void 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 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 +} + +int run_scm(argc, argv, iverbose, buf0stdin, initpath) + int argc; + char **argv; + int iverbose; + int buf0stdin; + char *initpath; +{ + SCM i; + do { + i = 0L; + if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) { + char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2]; + do { + switch (*str) { + case DIGITS: + i = i * 10 + (*str - '0'); + if (i <= 10000L) continue; /* the size limit should match Init.scm */ + default: + i = 0L; + } + break; + } while (* ++str); + } + init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */ + progargs = EOL; + progargs = makfromstrs(argc, argv); + + if (!dumped) { +#ifdef HAVE_DYNL + init_dynl(); +#endif +#ifdef INITS + INITS; /* call initialization of extension files */ +#endif + } + init_signals(); + i = repl_driver(initpath); + restore_signals(); +#ifdef TICKS + ticken = 0; +#endif +#ifdef FINALS + FINALS; /* call shutdown of extensions files */ +#endif /* for compatability with older modules */ + /* call finalization of user extensions */ + while (num_finals--) (finals[num_finals])(); + final_repl(); + free_storage(); /* free all allocated memory */ + if (i) break; + dumped = 0; + if (2 <= iverbose) fputs(";RESTART\n", stderr); + } while (!0); + if (2 <= iverbose) fputs(";EXIT\n", stderr); + fflush(stderr); + return (int)INUM(i); +} + +#ifdef vms +# define SYSTNAME "vms" +#endif +#ifdef unix +# define DIRSEP "/" +# ifndef MSDOS /* DJGPP defines both */ +# define SYSTNAME "unix" +# endif +#endif +#ifdef MWC +# define SYSTNAME "coherent" +# define DIRSEP "/" +#endif +#ifdef _Windows +# define SYSTNAME "windows" +# define DIRSEP "\\" +#else +# ifdef MSDOS +# define SYSTNAME "ms-dos" +# ifndef unix +# define DIRSEP "\\" +# endif +# endif +#endif +#ifdef __EMX__ +# define SYSTNAME "os/2" +# define DIRSEP "\\" +#endif +#ifdef __IBMC__ +# define SYSTNAME "os/2" +# define DIRSEP "\\" +#endif +#ifdef THINK_C +# define SYSTNAME "thinkc" +# define DIRSEP ":" +#endif +#ifdef AMIGA +# define SYSTNAME "amiga" +# define DIRSEP "/" +#endif +#ifdef atarist +# define SYSTNAME "atarist" +# define DIRSEP "\\" +#endif +#ifdef mach +# define SYSTNAME "mach" +# define DIRSEP "/" +#endif +#ifdef ARM_ULIB +# define SYSTNAME "acorn" +#endif +#ifdef nosve +# define INIT_FILE_NAME "Init_scm"; +# define DIRSEP "." +#endif + +SCM softtype() +{ +#ifdef nosve + return CAR(intern("nosve", 5)); +#else + return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); +#endif +} + +/* Concatentate str2 onto str1 at position n and return concatenated + string if file exists; 0 otherwise. */ + +char *scm_cat_path(str1, str2, n) + char *str1; + const char *str2; + long n; +{ + if (!n) n = strlen(str2); + if (str1) + { + long len = strlen(str1); + str1 = (char *)realloc(str1, (sizet)(len + n + 1)); + if (!str1) return 0; + strncat(str1 + len, str2, n); + return str1; + } + str1 = (char *)malloc((sizet)(n + 1)); + if (!str1) return 0; + str1[0] = 0; + strncat(str1, str2, n); + return str1; +} + +char *scm_try_path(path) + char *path; +{ + FILE *f; + /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */ + if (!path) return 0; + SYSCALL(f = fopen(path, "r");); + if (f) { + fclose(f); + return path; + } + free(path); + return 0; +} + +char *scm_sep_init_try(path, sep, initname) + char *path; + const char *sep, *initname; +{ + if (path) path = scm_cat_path(path, sep, 0L); + if (path) path = scm_cat_path(path, initname, 0L); + return scm_try_path(path); +} + +#ifdef MSDOS +char *dld_find_executable(file) + const char *file; +{ + return scm_cat_path(0L, file, 0L); +} +#endif + +#ifndef INIT_FILE_NAME +# define INIT_FILE_NAME "Init.scm" +#endif +#ifndef DIRSEP +# define DIRSEP "/" +#endif +#ifndef GENERIC_NAME +# define GENERIC_NAME "scm" +#endif + +/* Given dld_find_executable()'s best guess for the pathname of this + executable, find (and verify the existence of) initname in the + implementation-vicinity of this program. Returns a newly allocated + string if successful, 0 if not */ + +char *scm_find_impl_file(exec_path, generic_name, initname, sep) + char *exec_path; + const char *generic_name, *initname, *sep; +{ + char *sepptr = strrchr(exec_path, sep[0]); + char *extptr = exec_path + strlen(exec_path); + char *path = 0; + if (sepptr) { + long sepind = sepptr - exec_path + 1L; + + /* In case exec_path is in the source directory, look first in + exec_path's directory. */ + path = scm_cat_path(0L, exec_path, sepind - 1L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + +#ifdef MSDOS + if (!strcmp(extptr - 4, ".exe") || !strcmp(extptr - 4, ".com") || + !strcmp(extptr - 4, ".EXE") || !strcmp(extptr - 4, ".COM")) + extptr = extptr - 4; +#endif + + if (generic_name && + !strncmp(exec_path + sepind, generic_name, extptr - exec_path)) + generic_name = 0; + + /* If exec_path is in directory "exe" or "bin": */ + path = scm_cat_path(0L, exec_path, sepind - 1L); + sepptr = path + sepind - 4; + if (!strcmp(sepptr, "exe") || !strcmp(sepptr, "bin") || + !strcmp(sepptr, "EXE") || !strcmp(sepptr, "BIN")) { + char *peer; + + /* Look for initname in peer directory "lib". */ + if (path) { + strncpy(sepptr, "lib", 3); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + } + + /* Look for initname in peer directories "lib" and "src" in + subdirectory with the name of the executable (sans any type + extension like .EXE). */ + for(peer="lib";!0;peer="src") { + path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L); + if (path) { + strncpy(path + sepind - 4, peer, 3); + path[extptr - exec_path] = 0; + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + } + if (!strcmp(peer,"src")) break; + } + + if (generic_name) { + + /* Look for initname in peer directories "lib" and "src" in + subdirectory with the generic name. */ + for(peer="lib";!0;peer="src") { + path = scm_cat_path(0L, exec_path, sepind); + if (path) { + strncpy(path + sepind - 4, "lib", 3); + path = scm_cat_path(path, generic_name, 0L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + } + if (!strcmp(peer,"src")) break; + }}} + +#ifdef MSDOS + if (strlen(extptr)) { + /* If exec_path has type extension, look in a subdirectory with + the name of the executable sans the executable file's type + extension. */ + path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + + if (generic_name) { + + /* Also look in generic_name subdirectory. */ + path = scm_cat_path(0L, exec_path, sepind); + if (path) path = scm_cat_path(path, generic_name, 0L); + path = scm_sep_init_try(path, sep, initname); + if (path) return path; + }} +#endif + } + else { + + /* We don't have a parse-able exec_path. The only path to try is + just initname. */ + path = scm_cat_path(0L, initname, 0L); + if (path) path = scm_try_path(path); + if (path) return path; + } + return 0; +} + +#ifndef RTL +char *execpath = 0; +int main( argc, argv ) + int argc; + char **argv; +{ + int retval, buf0stdin = 0; + char *getenvpath, *implpath = 0; + +# ifndef nosve + getenvpath = getenv("SCM_INIT_PATH"); + if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L); + if (implpath) { + + /* The value of the environment variable supersedes other + locations, as long as the file exists. */ + implpath = scm_try_path(implpath); + if (!implpath) { + fputs("Value of SCM_INIT_PATH (=\"", stderr); + fputs(getenvpath, stderr); + fputs("\") not found; Trying elsewhere\n", stderr); + } + } +# endif + + if (!implpath) { + execpath = dld_find_executable(argv[0]); + if (execpath) { + /* fprintf(stderr, "dld found exe \"%s\"\n", execpath); fflush(stderr); */ + implpath = scm_find_impl_file(execpath, + GENERIC_NAME, INIT_FILE_NAME, DIRSEP); + /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */ + } +# ifdef IMPLINIT + if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L); +# endif + } +# ifndef GO32 + if (isatty(fileno(stdin))) { + buf0stdin = !0; /* stdin gets marked BUF0 in init_scm() */ +# ifndef NOSETBUF +# ifndef _DCC +# ifndef ultrix +# ifndef __WATCOMC__ +# ifndef THINK_C +# if (__TURBOC__ != 1) +# ifndef _Windows + setbuf(stdin, 0); /* Often setbuf isn't actually required */ +# endif +# endif +# endif +# endif +# endif +# endif + } +# endif +# endif + retval = run_scm(argc, argv, + (isatty(fileno(stdin)) && isatty(fileno(stdout))) + ? (argc <= 1) ? 2 : 1 : 0, + buf0stdin, + implpath ? implpath : ""); + if (implpath) free(implpath); + if (execpath) free(execpath); + return retval; +} +#endif + +#ifndef _Windows +char s_system[] = "system"; +SCM lsystem(cmd) + SCM cmd; +{ + ASSERT(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system); + ignore_signals(); +# ifdef AZTEC_C + cmd = MAKINUM(Execute(CHARS(cmd), 0, 0)); +# else + cmd = MAKINUM(0L+system(CHARS(cmd))); +# endif + unignore_signals(); + return cmd; +} +#endif + +char s_getenv[] = "getenv"; +char *getenv(); +SCM lgetenv(nam) + SCM nam; +{ + char *val; + ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv); + val = getenv(CHARS(nam)); + if (!val) return BOOL_F; + return makfrom0str(val); +} + +#ifdef vms +# include <descrip.h> +# include <ssdef.h> +char s_ed[] = "ed"; +SCM ed(fname) + SCM fname; +{ + struct dsc$descriptor_s d; + ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed); + d.dsc$b_dtype = DSC$K_DTYPE_T; + d.dsc$b_class = DSC$K_CLASS_S; + d.dsc$w_length = LENGTH(fname); + d.dsc$a_pointer = CHARS(fname); + /* I don't know what VMS does with signal handlers across the + edt$edit call. */ + ignore_signals(); + edt$edit(&d); + unignore_signals(); + return fname; +} +SCM vms_debug() +{ + lib$signal(SS$_DEBUG); + return UNSPECIFIED; +} +#endif + +static iproc subr0s[] = { + {"software-type", softtype}, + {"scm_init_extensions", scm_init_extensions}, +#ifdef vms + {"vms-debug", vms_debug}, +#endif +#ifdef SIGALRM +# ifndef AMIGA + {"pause", l_pause}, +# endif +#endif + {0, 0}}; +static iproc subr1s[] = { + {s_getenv, lgetenv}, +#ifndef _Windows + {s_system, lsystem}, +#endif +#ifdef vms + {s_ed, ed}, +#endif +#ifdef SIGALRM + {s_alarm, lalarm}, +#endif +#ifndef AMIGA +# ifndef _Windows + {s_sleep, l_sleep}, +# endif +#endif +#ifndef GO32 +# ifndef sun +# ifndef _WIN32 + {s_raise, l_raise}, +# endif +# endif +#endif + {0, 0}}; + +SCM *loc_features; +void add_feature(str) + char* str; +{ + *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features); +} +void init_features() +{ + loc_features = &CDR(sysintern("*features*", EOL)); + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1s, tc7_subr_1); +#ifdef TICKS + loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED)); + make_subr(s_ticks, tc7_subr_1o, lticks); +#endif +#ifdef RECKLESS + add_feature("reckless"); +#endif +#ifndef _Windows + add_feature(s_system); +#endif +#ifdef vms + add_feature(s_ed); +#endif + sysintern("*scm-version*", makfrom0str(SCMVERSION)); +} @@ -0,0 +1,330 @@ + + + +SCM(Jan 9 1995) SCM(Jan 9 1995) + + +NAME + scm - a Scheme Language Interpreter + +SYNOPSIS + scm [-a kbytes ] [-ibvqmu] [-p number ] [-c expression ] + [-e expression ] [-f filename ] [-l filename ] [-d file- + name ] [-r feature ] [-- | - | -s] [filename] [arguments + ...] + +DESCRIPTION + Scm is a Scheme interpreter. + + Upon startup scm loads the file specified by by the envi- + ronment variable SCM_INIT_PATH or by the parameter + IMPLINIT in the makefile (or scmfig.h) if SCM_INIT_PATH is + not defined. The makefiles attempt to set IMPLINIT to + "Init.scm" in the source directory. + + Unless the option -no-init-file occurs in the command + line, "Init.scm" checks to see if there is file + "ScmInit.scm" in the path specified by the environment + variable HOME (or in the current directory if HOME is + undefined). If it finds such a file it is loaded. + + "Init.scm" then looks for command input from one of three + sources: From an option on the command line, from a file + named on the command line, or from standard input. + + +OPTIONS + The options are processed in the order specified on the + command line. + + -akbytes + specifies that scm should allocate an initial heap- + size of kbytes. This option, if present, must be the + first on the command line. + + -no-init-file + Inhibits the loading of "ScmInit.scm" as described + above. + + -eexpression + + -cexpression + specifies that the scheme expression expression is to + be evaluated. These options are inspired by perl and + sh respectively. On Amiga systems the entire option + and argument need to be enclosed in qoutes. For + instance "-e(newline)". + + -rfeature + requires feature. This will load a file from SLIB if + that feature is not already supported. If feature is + + + + 1 + + + + + +SCM(Jan 9 1995) SCM(Jan 9 1995) + + + 2, 3, 4, or 5 scm will require the features necces- + sary to support R2RS, R3RS, R4RS, or proposed R5RS, + respectively. + + -lfilename + + -ffilename + loads filename. Scm will load the first (unoptioned) + file named on the command line if no -c, -e, -f, -l, + or -s option preceeds it. + + -dfilename + opens (read-only) the extended relational database + filename. If filename contains initialization code, + it will be run when the database is opened. + + -plevel + sets the prolixity (verboseness) to level. This is + the same as the scm command (verobse level ). + + -v (verbose mode) specifies that scm will print prompts, + evaluation times, notice of loading files, and + garbage collection statistics. This is the same as + -p3. + + -q (quiet mode) specifies that scm will print no extra + information. This is the same as -p0. + + -m specifies that subsequent loads, evaluations, and + user interactions will be with R4RS macro capability. + To use a specific R4RS macro implementation from SLIB + (instead of SLIB's default) put -r macropackage + before -m on the command line. + + -u specifies that subsequent loads, evaluations, and + user interactions will be without R4RS macro capabil- + ity. R4RS macro capability can be restored by a sub- + sequent -m on the command line or from Scheme code. + + -i specifies that scm should run interactively. That + means that scm will not terminate until the (quit) or + (exit) command is given, even if there are errors. + It also sets the prolixity level to 2 if it is less + than 2. This will print prompts, evaluation times, + and notice of loading files. The prolixity level can + be set by subsequent options. If scm is started from + a tty, it will assume that it should be interactive + unless given a subsequent -b option. + + -b specifies that scm should run non-interactively. + That means that scm will terminate after processing + the command line or if there are errors. + + -s specifies, by analogy with sh, that further options + + + + 2 + + + + + +SCM(Jan 9 1995) SCM(Jan 9 1995) + + + are to be treated as program aguments. + + - -- specifies that there are no more options on the + command line. + +ENVIRONMENT VARIABLES + SCM_INIT_PATH + is the pathname where scm will look for its initial- + ization code. The default is the file "Init.scm" in + the source directory. + + SCHEME_LIBRARY_PATH + is the SLIB Scheme library directory. + + HOME is the directory where "Init.scm" will look for the + user initialization file "ScmInit.scm". + +SCHEME VARIABLES + *argv* + contains the list of arguments to the program. + *argv* can change during argument processing. This + list is suitable for use as an argument to SLIB + getopt. + + *R4RS-macro* + controls whether loading and interaction support R4RS + macros. Define this in "ScmInit.scm" or files speci- + fied on the command line. This can be overridden by + subsequent -m and -u options. + + *interactive* + controls interactivity as explained for the -i and -b + options. Define this in "ScmInit.scm" or files spec- + ified on the command line. This can be overridden by + subsequent -i and -b options. + +EXAMPLES + % scm foo.scm arg1 arg2 arg3 + Load and execute the contents of foo.scm. Parameters + arg1 arg2 and arg3 are stored in the global list + *argv*. + + % scm -f foo.scm arg1 arg2 arg3 + The same. + + % scm -s foo.scm arg1 arg2 + Set *argv* to ("foo.scm" "arg1" "arg2") and enter + interactive session. + + % scm -e '(display (list-ref *argv* *optind*))' bar + Print ``bar'' + + % scm -rpretty-print -r format -i + Load pretty-print and format and enter interactive + + + + 3 + + + + + +SCM(Jan 9 1995) SCM(Jan 9 1995) + + + mode. + + % scm -r5 + Load dynamic-wind, values, and R4RS macros and enter + interactive (with macros) mode. + + % scm -r5 -r4 + Like above but rev4-optional-procedures are also + loaded. + +FEATURES + Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, + Unicos, VMS, Unix and similar systems. Support for ASCII + and EBCDIC character sets. + + Conforms to Revised^4 Report on the Algorithmic Language + Scheme and the IEEE P1178 specification. + + Support for SICP, R2RS, R3RS, and (proposed) R5RS scheme + code. + + Many Common Lisp functions: logand, logor, logxor, lognot, + ash, logcount, integer-length, bit-extract, defmacro, + macroexpand, macroexpand1, gentemp, defvar, force-output, + software-type, get-decoded-time, get-internal-run-time, + get-internal-real-time, delete-file, rename-file, copy- + tree, acons, and eval. + + Char-code-limit, most-positive-fixnum, most-negative- + fixnum, and internal-time-units-per-second constants. + *Features* and *load-pathname* variables. + + Arrays and bit-vectors. String ports and software emula- + tion ports. I/O extensions providing most of ANSI C and + POSIX.1 facilities. + + User definable responses to interrupts and errors, Pro- + cess-syncronization primitives, String regular expression + matching, and the CURSES screen management package. + + Available add-on packages including an interactive debug- + ger, database, X-window graphics, BGI graphics, Motif, and + Open-Windows packages. + + A compiler (HOBBIT, available separately) and dynamic + linking of compiled modules. + + Setable levels of monitoring and timing information + printed interactively (the `verbose' function). Restart, + quit, and exec. + +FILES + code.doc + Documentation on the internal representation and + + + + 4 + + + + + +SCM(Jan 9 1995) SCM(Jan 9 1995) + + + how to extend or include scm in other programs. + + scm.texi + Documentation of SCM in Texinfo format. + +AUTHOR + Aubrey Jaffer + (jaffer@ai.mit.edu) + +BUGS +SEE ALSO + The Scheme specifications for details on specific proce- + dures (ftp-swiss.ai.mit.edu:archive/scheme-reports/) or + + IEEE Std 1178-1990, + IEEE Standard for the Scheme Programming Language, + Institute of Electrical and Electronic Engineers, Inc., + New York, NY, 1991 + + Brian Harvey and Matthew Wright + Simply Scheme: Introducing Computer Science_ + MIT Press, 1994 ISBN 0-262-08226-8 + + R. Kent Dybvig, The Scheme Programming Language, + Prentice-Hall Inc, Englewood Cliffs, New Jersey 07632, USA + + H. Abelson, G. J. Sussman, and J. Sussman, + Structure and Interpretation of Computer Programs, + The MIT Press, Cambridge, Massachusetts, USA + + Enhancements in scm not in the standards are detailed in + MANUAL in the source directory. + + + + + + + + + + + + + + + + + + + + + + + + + + 5 + + @@ -0,0 +1,817 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "scm.h" SCM data types and external functions. */ + +#ifdef __cplusplus +extern "C" { +#endif + +typedef long SCM; +typedef struct {SCM car, cdr;} cell; +typedef struct {long sname;SCM (*cproc)();} subr; +typedef struct {char *string;SCM (*cproc)();} iproc; +typedef struct {long sname;double (*dproc)();} dsubr; + +#include <stdio.h> +#include "scmfig.h" + +#ifdef USE_ANSI_PROTOTYPES +# define P(s) s +#else +# define P(s) () +#endif + +#ifndef STDC_HEADERS + int isatty P((int)); +#endif + +typedef struct { + SCM (*mark)P((SCM)); + sizet (*free)P((CELLPTR)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); +} smobfuns; + +typedef struct { + SCM (*mark)P((SCM ptr)); + int (*free)P((FILE *p)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); + int (*fputc)P((int c, FILE *p)); + int (*fputs)P((char *s, FILE *p)); + sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); + int (*fflush)P((FILE *stream)); + int (*fgetc)P((FILE *p)); + int (*fclose)P((FILE *p)); +} ptobfuns; + +typedef struct { + SCM v; + sizet base; +} array; +typedef struct { + long lbnd; + long ubnd; + long inc; +} array_dim; + +#ifdef FLOATS +typedef struct {char *string;double (*cproc)P((double));} dblproc; +# ifdef SINGLES +# ifdef CDR_DOUBLES +typedef struct {SCM type;double num;} flo; +# else +typedef struct {SCM type;float num;} flo; +# endif +# endif +typedef struct {SCM type;double *real;} dbl; +#endif + +#define IMP(x) (6 & (int)(x)) +#define NIMP(x) (!IMP(x)) + +#define INUMP(x) (2 & (int)(x)) +#define NINUMP(x) (!INUMP(x)) +#define INUM0 ((SCM) 2) +#define ICHRP(x) ((0xff & (int)(x))==0xf4) +#define ICHR(x) ((unsigned char)((x)>>8)) +#define MAKICHR(x) (((x)<<8)+0xf4L) + +#define ILOCP(n) ((0xff & (int)(n))==0xfc) +#define ILOC00 (0x000000fcL) +#define IDINC (0x00100000L) +#define ICDR (0x00080000L) +#define IFRINC (0x00000100L) +#define IDSTMSK (-IDINC) +#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8)) +#define IDIST(n) (((unsigned long)(n))>>20) +#define ICDRP(n) (ICDR & (n)) + +/* ISYMP tests for ISPCSYM and ISYM */ +#define ISYMP(n) ((0x187 & (int)(n))==4) +/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */ +#define IFLAGP(n) ((0x87 & (int)(n))==4) +#define ISYMNUM(n) ((int)((n)>>9)) +#define ISYMCHARS(n) (isymnames[ISYMNUM(n)]) +#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) +#define MAKISYM(n) (((n)<<9)+0x74L) +#define MAKIFLAG(n) (((n)<<9)+0x174L) + +extern char *isymnames[]; +#define NUM_ISPCSYM 14 +#define IM_AND MAKSPCSYM(0) +#define IM_BEGIN MAKSPCSYM(1) +#define IM_CASE MAKSPCSYM(2) +#define IM_COND MAKSPCSYM(3) +#define IM_DO MAKSPCSYM(4) +#define IM_IF MAKSPCSYM(5) +#define IM_LAMBDA MAKSPCSYM(6) +#define IM_LET MAKSPCSYM(7) +#define IM_LETSTAR MAKSPCSYM(8) +#define IM_LETREC MAKSPCSYM(9) +#define IM_OR MAKSPCSYM(10) +#define IM_QUOTE MAKSPCSYM(11) +#define IM_SET MAKSPCSYM(12) +#define IM_DEFINE MAKSPCSYM(13) + +#define s_and (ISYMCHARS(IM_AND)+2) +#define s_begin (ISYMCHARS(IM_BEGIN)+2) +#define s_case (ISYMCHARS(IM_CASE)+2) +#define s_cond (ISYMCHARS(IM_COND)+2) +#define s_do (ISYMCHARS(IM_DO)+2) +#define s_if (ISYMCHARS(IM_IF)+2) +#define s_lambda (ISYMCHARS(IM_LAMBDA)+2) +#define s_let (ISYMCHARS(IM_LET)+2) +#define s_letstar (ISYMCHARS(IM_LETSTAR)+2) +#define s_letrec (ISYMCHARS(IM_LETREC)+2) +#define s_or (ISYMCHARS(IM_OR)+2) +#define s_quote (ISYMCHARS(IM_QUOTE)+2) +#define s_set (ISYMCHARS(IM_SET)+2) +#define s_define (ISYMCHARS(IM_DEFINE)+2) + +extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing; +#define s_apply (ISYMCHARS(IM_APPLY)+2) + +/* each symbol defined here must have a unique number which */ + /* corresponds to it's position in isymnames[] in sys.c */ +#define IM_APPLY MAKISYM(14) +#define IM_CONT MAKISYM(15) + +#define NUM_ISYMS 16 + +#define BOOL_F MAKIFLAG(NUM_ISYMS+0) +#define BOOL_T MAKIFLAG(NUM_ISYMS+1) +#define UNDEFINED MAKIFLAG(NUM_ISYMS+2) +#define EOF_VAL MAKIFLAG(NUM_ISYMS+3) +#ifdef SICP +# define EOL BOOL_F +#else +# define EOL MAKIFLAG(NUM_ISYMS+4) +#endif +#define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5) + +/* Now some unnamed flags used as magic cookies by repl_driver. */ +/* Argument n can range from -4 to 16 */ +#ifdef SHORT_INT +#define COOKIE(n) (n) +#define UNCOOK(f) (f) +#else +#define COOKIE(n) MAKIFLAG(NUM_ISYMS+6+4+n) +#define UNCOOK(f) (ISYMNUM(f)-(NUM_ISYMS+6+4)) +#endif + +#define FALSEP(x) (BOOL_F==(x)) +#define NFALSEP(x) (BOOL_F != (x)) +/* BOOL_NOT returns the other boolean. The order of ^s here is + important for Borland C++. */ +#define BOOL_NOT(x) ((x) ^ (BOOL_T ^ BOOL_F)) +#define NULLP(x) (EOL==(x)) +#define NNULLP(x) (EOL != (x)) +#define UNBNDP(x) (UNDEFINED==(x)) +#define CELLP(x) (!NCELLP(x)) +#define NCELLP(x) ((sizeof(cell)-1) & (int)(x)) + +#define GCMARKP(x) (1 & (int)CDR(x)) +#define GC8MARKP(x) (0x80 & (int)CAR(x)) +#define SETGCMARK(x) CDR(x) |= 1; +#define CLRGCMARK(x) CDR(x) &= ~1L; +#define SETGC8MARK(x) CAR(x) |= 0x80; +#define CLRGC8MARK(x) CAR(x) &= ~0x80L; +#define TYP3(x) (7 & (int)CAR(x)) +#define TYP7(x) (0x7f & (int)CAR(x)) +#define TYP7S(x) (0x7d & (int)CAR(x)) +#define TYP16(x) (0xffff & (int)CAR(x)) +#define TYP16S(x) (0xfeff & (int)CAR(x)) +#define GCTYP16(x) (0xff7f & (int)CAR(x)) + +#define NCONSP(x) (1 & (int)CAR(x)) +#define CONSP(x) (!NCONSP(x)) +#define ECONSP(x) (CONSP(x) || (1==TYP3(x))) +#define NECONSP(x) (NCONSP(x) && (1 != TYP3(x))) + +#define CAR(x) (((cell *)(SCM2PTR(x)))->car) +#define CDR(x) (((cell *)(SCM2PTR(x)))->cdr) +#define GCCDR(x) (~1L & CDR(x)) +#define SETCDR(x, v) CDR(x) = (SCM)(v) + +#define CLOSUREP(x) (TYP3(x)==tc3_closure) +#define CODE(x) (CAR(x)-tc3_closure) +#define SETCODE(x, e) CAR(x) = (e)+tc3_closure +#define ENV(x) CDR(x) + +#define PORTP(x) (TYP7(x)==tc7_port) +#define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN)) +#define OPINPORTP(x) (((0x7f | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG)) +#define OPOUTPORTP(x) (((0x7f | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG)) +#define OPIOPORTP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc7_port | OPN | RDNG | WRTNG)) +#define FPORTP(x) (TYP16S(x)==tc7_port) +#define OPFPORTP(x) (((0xfeff | OPN) & CAR(x))==(tc7_port | OPN)) +#define OPINFPORTP(x) (((0xfeff | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG)) +#define OPOUTFPORTP(x) (((0xfeff | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG)) + +#define INPORTP(x) (((0x7f | RDNG) & CAR(x))==(tc7_port | RDNG)) +#define OUTPORTP(x) (((0x7f | WRTNG) & CAR(x))==(tc7_port | WRTNG)) +#define OPENP(x) (OPN & CAR(x)) +#define CLOSEDP(x) (!OPENP(x)) +#define STREAM(x) ((FILE *)(CDR(x))) +#define SETSTREAM SETCDR +#define CRDYP(port) (CAR(port) & CRDY) +#define CLRDY(port) {CAR(port) &= CUC;} +#define CGETUN(port) ((int)SRS(CAR(port), 22)) +#define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;} + +#define tc_socket (tc7_port | OPN) +#define SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket)) +#define SOCKTYP(x) (CAR(x)>>24) + +#define DIRP(x) (NIMP(x) && (TYP16(x)==(tc16_dir))) +#define OPDIRP(x) (NIMP(x) && (CAR(x)==(tc16_dir | OPN))) + +#ifdef FLOATS +# define INEXP(x) (TYP16(x)==tc16_flo) +# define CPLXP(x) (CAR(x)==tc_dblc) +# define REAL(x) (*(((dbl *) (SCM2PTR(x)))->real)) +# define IMAG(x) (*((double *)(CHARS(x)+sizeof(double)))) +/* ((&REAL(x))[1]) */ +# ifdef SINGLES +# define REALP(x) ((~REAL_PART & CAR(x))==tc_flo) +# define SINGP(x) (CAR(x)==tc_flo) +# define FLO(x) (((flo *)(SCM2PTR(x)))->num) +# define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x)) +# else /* SINGLES */ +# define REALP(x) (CAR(x)==tc_dblr) +# define REALPART REAL +# endif /* SINGLES */ +#endif + +#ifdef FLOATS +# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x))) +#else +# ifdef BIGDIG +# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x))) +# else +# define NUMBERP INUMP +# endif +#endif +#define NUMP(x) ((0xfcff & (int)CAR(x))==tc7_smob) +#define BIGP(x) (TYP16S(x)==tc16_bigpos) +#define BIGSIGN(x) (0x0100 & (int)CAR(x)) +#define BDIGITS(x) ((BIGDIG *)(CDR(x))) +#define NUMDIGS(x) ((sizet)(CAR(x)>>16)) +#define SETNUMDIGS(x, v, t) CAR(x) = (((v)+0L)<<16)+(t) + +#define SNAME(x) ((CAR(x)>>8)?(SCM)(heap_org+(CAR(x)>>8)):nullstr) +#define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc) +#define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc) +#define CCLO_SUBR(x) (VELTS(x)[0]) + +#define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol) +#define STRINGP(x) (TYP7(x)==tc7_string) +#define NSTRINGP(x) (!STRINGP(x)) +#define VECTORP(x) (TYP7(x)==tc7_vector) +#define NVECTORP(x) (!VECTORP(x)) +#define LENGTH(x) (((unsigned long)CAR(x))>>8) +#define LENGTH_MAX (0xffffffL) +#define SETLENGTH(x, v, t) CAR(x) = ((v)<<8)+(t) +#define CHARS(x) ((char *)(CDR(x))) +#define UCHARS(x) ((unsigned char *)(CDR(x))) +#define VELTS(x) ((SCM *)CDR(x)) +#define SETCHARS SETCDR +#define SETVELTS SETCDR + +extern long tc16_array; +#define ARRAYP(a) (tc16_array==TYP16(a)) +#define ARRAY_V(a) (((array *)CDR(a))->v) +/*#define ARRAY_NDIM(x) NUMDIGS(x)*/ +#define ARRAY_NDIM(x) ((sizet)(CAR(x)>>17)) +#define ARRAY_CONTIGUOUS 0x10000 +#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & (int)CAR(x)) +#define ARRAY_BASE(a) (((array *)CDR(a))->base) +#define ARRAY_DIMS(a) ((array_dim *)(CHARS(a)+sizeof(array))) + +#define FREEP(x) (CAR(x)==tc_free_cell) +#define NFREEP(x) (!FREEP(x)) + +#define SMOBNUM(x) (0x0ff & (CAR(x)>>8)); +#define PTOBNUM(x) (0x0ff & (CAR(x)>>8)); + +#define DIGITS '0':case '1':case '2':case '3':case '4':\ + case '5':case '6':case '7':case '8':case '9' + +/* Aggregated types for dispatch in switch statements. */ + +#define 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 +#define 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 +#define 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 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 tcs_subrs tc7_asubr:case tc7_subr_0:case tc7_subr_1:case tc7_cxr:\ + case tc7_subr_3:case tc7_subr_2:case tc7_rpsubr:case tc7_subr_1o:\ + case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr +#define tcs_symbols tc7_ssymbol:case tc7_msymbol +#define tcs_bignums tc16_bigpos:case tc16_bigneg + +#define tc3_cons 0 +#define tc3_cons_gloc 1 +#define tc3_closure 3 + +#define tc7_ssymbol 5 +#define tc7_msymbol 7 +#define tc7_string 13 +#define tc7_vector 15 +#define tc7_bvect 21 +/* spare 23 */ +#define tc7_ivect 29 +#define tc7_uvect 31 +/* spare 37 39 */ +#define tc7_fvect 45 +#define tc7_dvect 47 +#define tc7_cvect 53 +#define tc7_port 55 +#define tc7_contin 61 +#define tc7_cclo 63 + +/* spare 69 71 77 79 */ +#define tc7_subr_0 85 +#define tc7_subr_1 87 +#define tc7_cxr 93 +#define tc7_subr_3 95 +#define tc7_subr_2 101 +#define tc7_asubr 103 +#define tc7_subr_1o 109 +#define tc7_subr_2o 111 +#define tc7_lsubr_2 117 +#define tc7_lsubr 119 +#define tc7_rpsubr 125 + +#define tc7_smob 127 +#define tc_free_cell 127 + +#define tc16_flo 0x017f +#define tc_flo 0x017fL + +#define REAL_PART (1L<<16) +#define IMAG_PART (2L<<16) +#define tc_dblr (tc16_flo|REAL_PART) +#define tc_dblc (tc16_flo|REAL_PART|IMAG_PART) + +#define tc16_bigpos 0x027f +#define tc16_bigneg 0x037f + +#define OPN (1L<<16) +#define RDNG (2L<<16) +#define WRTNG (4L<<16) +#define BUF0 (8L<<16) +#define CRDY (32L<<16) +#define CUC 0x001fffffL + +extern sizet numsmob, numptob; +extern smobfuns *smobs; +extern ptobfuns *ptobs; +extern ptobfuns pipob; +#define tc16_fport (tc7_port + 0*256L) +#define tc16_pipe (tc7_port + 1*256L) +#define tc16_strport (tc7_port + 2*256L) +#define tc16_sfport (tc7_port + 3*256L) +extern long tc16_dir; + +extern SCM sys_protects[]; +#define cur_inp sys_protects[0] +#define cur_outp sys_protects[1] +#define cur_errp sys_protects[2] +#define def_inp sys_protects[3] +#define def_outp sys_protects[4] +#define def_errp sys_protects[5] +#define listofnull sys_protects[6] +#define undefineds sys_protects[7] +#define nullvect sys_protects[8] +#define nullstr sys_protects[9] +#define progargs sys_protects[10] +#define transcript sys_protects[11] +#define rootcont sys_protects[12] +#define dynwinds sys_protects[13] +#define stacktrace sys_protects[14] +#ifdef FLOATS +# define flo0 sys_protects[15] +# define NUM_PROTECTS 16 +#else +# define NUM_PROTECTS 15 +#endif + +/* now for connects between source files */ + +extern sizet num_finals; +extern void (**finals)P((void)); +extern unsigned char upcase[], downcase[]; +extern SCM symhash; +extern int symhash_dim; +extern long heap_size; +extern CELLPTR heap_org; +extern SCM freelist; +extern long gc_cells_collected, gc_malloc_collected, gc_ports_collected; +extern long gc_syms_collected; +extern long cells_allocated, lcells_allocated, mallocated, lmallocated; +extern long mtrigger; +extern SCM *loc_loadpath; +extern SCM *loc_errobj; +extern SCM loadport; +extern long linum; +extern int errjmp_bad, ints_disabled, sig_deferred, alrm_deferred; +extern SCM exitval; +extern int cursinit; +extern unsigned int poll_count, tick_count; +extern int dumped; +extern char *execpath; + +/* strings used in several source files */ + +extern char s_read[], s_write[], s_newline[], s_system[]; +extern char s_make_string[], s_make_vector[], s_list[], s_op_pipe[]; +#define s_string (s_make_string+5) +#define s_vector (s_make_vector+5) +#define s_pipe (s_op_pipe+5) +extern char s_make_sh_array[]; +#define s_array (s_make_sh_array+12) +extern char s_ccl[]; +#define s_limit (s_ccl+10) +extern char s_close_port[]; +#define s_port_type (s_close_port+6) + +/* function prototypes */ + +void gc_mark P((SCM p)); +void han_sig P((void)); +void han_alrm P((void)); +char *must_malloc P((long len, char *what)); +char *must_realloc P((char *where, long olen, long len, char *what)); +void must_free P((char *obj)); +long ilength P((SCM sx)); +SCM hash P((SCM obj, SCM n)); +SCM hashv P((SCM obj, SCM n)); +SCM hashq P((SCM obj, SCM n)); +SCM obhash P((SCM obj)); +SCM obunhash P((SCM obj)); +unsigned long strhash P((unsigned char *str, sizet len, unsigned long n)); +unsigned long hasher P((SCM obj, unsigned long n, sizet d)); +SCM repl_driver P((char *initpath)); +SCM lroom P((SCM args)); +long newsmob P((smobfuns *smob)); +long newptob P((ptobfuns *ptob)); +void prinport P((SCM exp, SCM port, char *type)); +void repl P((void)); +void growth_mon P((char *obj, long size, char *units)); +void gc_start P((char *what)); +void gc_end P((void)); +void heap_report P((void)); +void exit_report P((void)); +void stack_report P((void)); +void iprin1 P((SCM exp, SCM port, int writing)); +void intprint P((long n, int radix, SCM port)); +void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing)); +void lputc P((int c, SCM port)); +void lputs P((char *s, SCM port)); +int lfwrite P((char *ptr, sizet size, sizet nitems, SCM port)); +int lgetc P((SCM port)); +void lungetc P((int c, SCM port)); +char *grow_tok_buf P((SCM tok_buf)); +long mode_bits P((char *modes)); +long time_in_msec P((long x)); +SCM my_time P((void)); +SCM your_time P((void)); +void init_iprocs P((iproc *subra, int type)); +void init_scm P((int iverbose, int buf0stdin, long init_heap_size)); +SCM scm_init_extensions P((void)); +void ignore_signals P((void)); +void unignore_signals P((void)); +void free_storage P((void)); +void add_feature P((char *str)); +int raprin1 P((SCM exp, SCM port, int writing)); +SCM markcdr P((SCM ptr)); +SCM mark0 P((SCM ptr)); +SCM equal0 P((SCM ptr1, SCM ptr2)); +sizet free0 P((CELLPTR ptr)); +void warn P((char *str1, char *str2)); +void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr)); +void wta P((SCM arg, char *pos, char *s_subr)); +SCM intern P((char *name, sizet len)); +SCM sysintern P((char *name, SCM val)); +SCM sym2vcell P((SCM sym)); +SCM makstr P((long len)); +SCM make_subr P((char *name, int type, SCM (*fcn)())); +SCM closure P((SCM code, SCM env)); +SCM makprom P((SCM code)); +SCM force P((SCM x)); +SCM makarb P((SCM name)); +SCM tryarb P((SCM arb)); +SCM relarb P((SCM arb)); +SCM ceval P((SCM x, SCM env)); +SCM prolixity P((SCM arg)); +SCM gc_for_newcell P((void)); +SCM gc P((void)); +SCM tryload P((SCM filename)); +SCM acons P((SCM w, SCM x, SCM y)); +SCM cons2 P((SCM w, SCM x, SCM y)); +SCM resizuve P((SCM vect, SCM len)); +SCM lnot P((SCM x)); +SCM booleanp P((SCM obj)); +SCM eq P((SCM x, SCM y)); +SCM equal P((SCM x, SCM y)); +SCM consp P((SCM x)); +SCM cons P((SCM x, SCM y)); +SCM nullp P((SCM x)); +SCM setcar P((SCM pair, SCM value)); +SCM setcdr P((SCM pair, SCM value)); +SCM listp P((SCM x)); +SCM list P((SCM objs)); +SCM length P((SCM x)); +SCM append P((SCM args)); +SCM reverse P((SCM lst)); +SCM list_ref P((SCM lst, SCM k)); +SCM memq P((SCM x, SCM lst)); +SCM member P((SCM x, SCM lst)); +SCM memv P((SCM x, SCM lst)); +SCM assq P((SCM x, SCM alist)); +SCM assoc P((SCM x, SCM alist)); +SCM symbolp P((SCM x)); +SCM symbol2string P((SCM s)); +SCM string2symbol P((SCM s)); +SCM numberp P((SCM x)); +SCM exactp P((SCM x)); +SCM inexactp P((SCM x)); +SCM eqp P((SCM x, SCM y)); +SCM lessp P((SCM x, SCM y)); +SCM zerop P((SCM z)); +SCM positivep P((SCM x)); +SCM negativep P((SCM x)); +SCM oddp P((SCM n)); +SCM evenp P((SCM n)); +SCM lmax P((SCM x, SCM y)); +SCM lmin P((SCM x, SCM y)); +SCM sum P((SCM x, SCM y)); +SCM difference P((SCM x, SCM y)); +SCM product P((SCM x, SCM y)); +SCM divide P((SCM x, SCM y)); +SCM lquotient P((SCM x, SCM y)); +SCM absval P((SCM x)); +SCM lremainder P((SCM x, SCM y)); +SCM modulo P((SCM x, SCM y)); +SCM lgcd P((SCM x, SCM y)); +SCM llcm P((SCM n1, SCM n2)); +SCM number2string P((SCM x, SCM radix)); +SCM istring2number P((char *str, long len, long radix)); +SCM string2number P((SCM str, SCM radix)); +SCM istr2flo P((char *str, long len, long radix)); +SCM mkbig P((sizet nlen, int sign)); +SCM mkstrport P((SCM pos, SCM str, long modes, char *caller)); +SCM long2big P((long n)); +SCM ulong2big P((unsigned long n)); +SCM big2inum P((SCM b, sizet l)); +sizet iint2str P((long num, int rad, char *p)); +SCM floequal P((SCM x, SCM y)); +SCM uve_equal P((SCM u, SCM v)); +SCM raequal P((SCM ra0, SCM ra1)); +SCM array_equal P((SCM u, SCM v)); +int rafill P((SCM ra, SCM fill, SCM ignore)); +SCM uve_fill P((SCM uve, SCM fill)); +SCM array_fill P((SCM ra, SCM fill)); +SCM array_prot P((SCM ra)); +int bigprint P((SCM exp, SCM port, int writing)); +int floprint P((SCM sexp, SCM port, int writing)); +SCM istr2int P((char *str, long len, long radix)); +SCM istr2bve P((char *str, long len)); +void ipruk P((char *hdr, SCM ptr, SCM port)); +SCM charp P((SCM x)); +SCM char_lessp P((SCM x, SCM y)); +SCM chci_eq P((SCM x, SCM y)); +SCM chci_lessp P((SCM x, SCM y)); +SCM char_alphap P((SCM chr)); +SCM char_nump P((SCM chr)); +SCM char_whitep P((SCM chr)); +SCM char_upperp P((SCM chr)); +SCM char_lowerp P((SCM chr)); +SCM char2int P((SCM chr)); +SCM int2char P((SCM n)); +SCM char_upcase P((SCM chr)); +SCM char_downcase P((SCM chr)); +SCM stringp P((SCM x)); +SCM string P((SCM chrs)); +SCM make_string P((SCM k, SCM chr)); +SCM string2list P((SCM str)); +SCM st_length P((SCM str)); +SCM st_ref P((SCM str, SCM k)); +SCM st_set P((SCM str, SCM k, SCM chr)); +SCM st_equal P((SCM s1, SCM s2)); +SCM stci_equal P((SCM s1, SCM s2)); +SCM st_lessp P((SCM s1, SCM s2)); +SCM stci_lessp P((SCM s1, SCM s2)); +SCM substring P((SCM str, SCM start, SCM end)); +SCM st_append P((SCM args)); +SCM vectorp P((SCM x)); +SCM vector_length P((SCM v)); +SCM vector P((SCM l)); +SCM vector_ref P((SCM v, SCM k)); +SCM vector_set P((SCM v, SCM k, SCM obj)); +SCM make_vector P((SCM k, SCM fill)); +SCM vector2list P((SCM v)); +SCM for_each P((SCM proc, SCM arg1, SCM args)); +SCM procedurep P((SCM obj)); +SCM apply P((SCM proc, SCM arg1, SCM args)); +SCM map P((SCM proc, SCM arg1, SCM args)); +SCM scm_make_cont P((void)); +SCM copytree P((SCM obj)); +SCM eval P((SCM obj)); +SCM input_portp P((SCM x)); +SCM output_portp P((SCM x)); +SCM cur_input_port P((void)); +SCM cur_output_port P((void)); +SCM i_setbuf0 P((SCM port)); +SCM open_file P((SCM filename, SCM modes)); +SCM open_pipe P((SCM pipestr, SCM modes)); +SCM close_port P((SCM port)); +SCM lread P((SCM port)); +SCM scm_read_char P((SCM port)); +SCM peek_char P((SCM port)); +SCM eof_objectp P((SCM x)); +SCM lwrite P((SCM obj, SCM port)); +SCM display P((SCM obj, SCM port)); +SCM newline P((SCM port)); +SCM write_char P((SCM chr, SCM port)); +SCM file_position P((SCM port)); +SCM file_set_position P((SCM port, SCM pos)); +SCM lgetenv P((SCM nam)); +SCM prog_args P((void)); +SCM makacro P((SCM code)); +SCM makmacro P((SCM code)); +SCM makmmacro P((SCM code)); +void poll_routine P((void)); +void tick_signal P((void)); +void stack_check P((void)); +SCM list2ura P((SCM ndim, SCM prot, SCM lst)); +SCM make_ra P((int ndim)); +SCM makflo P((float x)); +SCM arrayp P((SCM v, SCM prot)); +SCM array_contents P((SCM ra, SCM strict)); +SCM uve_read P((SCM v, SCM port)); +SCM uve_write P((SCM v, SCM port)); +SCM ura_read P((SCM v, SCM port)); +SCM ura_write P((SCM v, SCM port)); +SCM aset P((SCM v, SCM obj, SCM args)); +SCM aref P((SCM v, SCM args)); +SCM cvref P((SCM v, sizet pos, SCM last)); +SCM quit P((SCM n)); +void add_final P((void (*final)(void))); +SCM makcclo P((SCM proc, long len)); +SCM make_uve P((long k, SCM prot)); +SCM ra2contig P((SCM ra, int copy)); +SCM sc2array P((SCM s, SCM ra, SCM prot)); +SCM array_copy P((SCM src, SCM dst)); +long aind P((SCM ra, SCM args, char *what)); +SCM scm_eval_string P((SCM str)); +SCM scm_load_string P((SCM str)); +void scm_print_stack P((SCM stk)); +char * dld_find_executable P((const char* command)); +SCM scm_unexec P((const SCM pathname)); +char * scm_cat_path P((char *str1, const char *str2, long n)); + + /* Defined in "rope.c" */ +SCM long2num P((long n)); +SCM ulong2num P((unsigned long n)); +unsigned char num2uchar P((SCM num, char *pos, char *s_caller)); +unsigned short num2ushort P((SCM num, char *pos, char *s_caller)); +unsigned long num2ulong P((SCM num, char *pos, char *s_caller)); + long num2long P((SCM num, char *pos, char *s_caller)); + double num2dbl P((SCM num, char *pos, char *s_caller)); +SCM makfromstr P((char *src, sizet len)); +SCM makfromstrs P((int argc, char **argv)); +SCM makfrom0str P((char *scr)); +char **makargvfrmstrs P((SCM args, char *s_v)); +void must_free_argv P((char **argv)); +SCM scm_evstr P((char *str)); +void scm_ldstr P((char *str)); +int scm_ldfile P((char *path)); +int scm_ldprog P((char *path)); +unsigned long scm_addr P((SCM args, char *name)); + +#ifdef FLOATS +SCM makdbl P((double x, double y)); +SCM dbl2big P((double d)); +double big2dbl P((SCM b)); +double lasinh P((double x)); +double lacosh P((double x)); +double latanh P((double x)); +double ltrunc P((double x)); +double round P((double x)); +double floident P((double x)); +#endif + +#ifdef BIGDIG +void longdigs P((long x, BIGDIG digs [DIGSPERLONG ])); +SCM adjbig P((SCM b, sizet nlen)); +SCM normbig P((SCM b)); +SCM copybig P((SCM b, int sign)); +SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny)); +SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn)); +unsigned int divbigdig P((BIGDIG *ds, sizet h, BIGDIG div)); +SCM divbigint P((SCM x, long z, int sgn, int mode)); +SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn, + int modes)); +long pseudolong P((long x)); +#endif +int bigcomp P((SCM x, SCM y)); +SCM bigequal P((SCM x, SCM y)); + +#ifdef RECKLESS +# define ASSERT(_cond, _arg, _pos, _subr) ; +# define ASRTGO(_cond, _label) ; +#else +# define ASSERT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)(_pos), _subr); +# define ASRTGO(_cond, _label) if(!(_cond)) goto _label; +#endif + +#define ARGn 0 +#define ARG1 1 +#define ARG2 2 +#define ARG3 3 +#define ARG4 4 +#define ARG5 5 + /* following must match entry indexes in errmsgs[] */ +#define WNA 6 +#define OVFLOW 7 +#define OUTOFRANGE 8 +#define NALLOC 9 +#define EXIT 10 +#define HUP_SIGNAL 11 +#define INT_SIGNAL 12 +#define FPE_SIGNAL 13 +#define BUS_SIGNAL 14 +#define SEGV_SIGNAL 15 +#define ALRM_SIGNAL 16 + +#define EVAL(x, env) (IMP(x)?(x):ceval((x), (env))) +#define SIDEVAL(x, env) if NIMP(x) ceval((x), (env)) + +#define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\ + else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}} + +#ifdef __cplusplus +} +#endif diff --git a/scm.texi b/scm.texi new file mode 100644 index 0000000..d7270f6 --- /dev/null +++ b/scm.texi @@ -0,0 +1,6911 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename scm.info +@settitle SCM +@setchapternewpage on +@c Choices for setchapternewpage are {on,off,odd}. +@paragraphindent 2 +@c %**end of header + +@iftex +@finalout +@c DL: lose the egregious vertical whitespace, esp. around examples +@c but paras in @defun-like things don't have parindent +@parskip 4pt plus 1pt +@end iftex + +@titlepage +@title SCM +@subtitle Scheme Implementation +@subtitle Version 4e6 +@subtitle March 1996 +@author by Aubrey Jaffer + +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end titlepage + +@node Top, Copying, (dir), (dir) + + +@ifinfo +This manual documents the SCM Scheme implementation. The most recent +information about SCM can be found on SCM's @dfn{WWW} home page: +@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html + + +Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation approved +by the author. +@end ifinfo + +@menu +* Copying:: Conditions for copying and changing SCM. +* Overview:: Whats here and how to start using it. +* Installing SCM:: Where it goes and how to get it there. +* The Language:: Reference. +* Packages:: Optional Capabilities. +* The Implementation:: How it works. +* Procedure and Macro Index:: +* Variable Index:: +* Type Index:: +@end menu + +@node Copying, Overview, Top, Top +@chapter Copying + +@center COPYRIGHT (c) 1989 BY +@center PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. +@center ALL RIGHTS RESERVED + +@noindent +Permission to use, copy, modify, distribute and sell this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all copies +and that both that copyright notice and this permission notice appear +in supporting documentation, and that the name of Paradigm Associates +Inc not be used in advertising or publicity pertaining to distribution +of the software without specific, written prior permission. + +@noindent +PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +@noindent +gjc@@paradigm.com +@flushright +Phone: 617-492-6079 +@end flushright +@flushleft +Paradigm Associates Inc +29 Putnam Ave, Suite 6 +Cambridge, MA 02138 +@end flushleft + +@sp 2 + +@center Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 +@center Free Software Foundation, Inc. +@center 675 Mass Ave, Cambridge, MA 02139, USA + +@noindent +Permission to use, copy, modify, distribute, and sell this software and +its documentation for any purpose is hereby granted without fee, +provided that the above copyright notice appear in all copies and that +both that copyright notice and this permission notice appear in +supporting documentation. + +@center NO WARRANTY + +@noindent +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. + +@noindent +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. + +@node Overview, Installing SCM, Copying, Top +@chapter Overview + +@noindent +Scm is a portable Scheme implementation written in C. Scm provides a +machine independent platform for [JACAL], a symbolic algebra system. + +@iftex +@noindent +The most recent information about SCM can be found on SCM's @dfn{WWW} +home page: +@ifset html +<A HREF="http://www-swiss.ai.mit.edu/~jaffer/SCM.html"> +@end ifset + +@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html + +@ifset html +</A> +@end ifset +@end iftex + +@menu +* SCM Features:: +* SCM Authors:: +* Bibliography:: +* Invoking SCM:: +* SCM Options:: +* SCM Variables:: +* SCM Examples:: +* SCM Session:: +* Editing Scheme Code:: +* Debugging Scheme Code:: +@end menu + +@node SCM Features, SCM Authors, Overview, Overview +@section Features + +@itemize @bullet +@item +Conforms to Revised^4 Report on the Algorithmic Language Scheme [R4RS] +and the [IEEE] P1178 specification. +@item +Support for [SICP], [R2RS], [R3RS], and (proposed) [R5RS] scheme code. +@item +Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, +Unix and similar systems. Supports ASCII and EBCDIC character sets. +@item +Is fully documented in @TeX{}info form, allowing documentation to be +generated in info, @TeX{}, html, nroff, and troff formats. +@item +Supports inexact real and complex numbers, 30 bit immediate integers and +large precision integers. +@item +Many Common Lisp functions: @code{logand}, @code{logor}, @code{logxor}, +@code{lognot}, @code{ash}, @code{logcount}, @code{integer-length}, +@code{bit-extract}, @code{defmacro}, @code{macroexpand}, +@code{macroexpand1}, @code{gentemp}, @code{defvar}, @code{force-output}, +@code{software-type}, @code{get-decoded-time}, +@code{get-internal-run-time}, @code{get-internal-real-time}, +@code{delete-file}, @code{rename-file}, @code{copy-tree}, @code{acons}, +and @code{eval}. +@item +@code{Char-code-limit}, @code{most-positive-fixnum}, +@code{most-negative-fixnum}, @code{and internal-time-units-per-second} +constants. @code{*Features*} and @code{*load-pathname*} variables. +@item +Arrays and bit-vectors. String ports and software emulation ports. +I/O extensions providing ANSI C and POSIX.1 facilities. +@item +Interfaces to standard libraries including REGEX string regular +expression matching and the CURSES screen management package. +@item +Available add-on packages including an interactive debugger, database, +X-window graphics, BGI graphics, Motif, and Open-Windows packages. +@item +A compiler (HOBBIT, available separately) and dynamic linking of +compiled modules. +@item +User definable responses to interrupts and errors, +Process-syncronization primitives. Setable levels of monitoring and +timing information printed interactively (the @code{verbose} function). +@code{Restart}, @code{quit}, and @code{exec}. +@end itemize + +@node SCM Authors, Bibliography, SCM Features, Overview +@section Authors + +@table @b +@item Aubrey Jaffer (jaffer@@ai.mit.edu) +Most of SCM. +@item Radey Shouman +Arrays. @code{gsubr}s, compiled closures, and records. +@item Jerry D. Hedden +Real and Complex functions. Fast mixed type arithmetics. +@item Hugh Secker-Walker +Syntax checking and memoization of special forms by evaluator. Storage +allocation strategy and parameters. +@item George Carrette +@dfn{Siod}, written by George Carrette, was the starting point for SCM. +The major innovations taken from Siod are the evaluator's use of the +C-stack and being able to garbage collect off the C-stack +(@pxref{Garbage Collection}). +@end table + +@noindent +There are many other contributors to SCM. They are acknowledged in the +file @file{ChangeLog}, a log of changes that have been made to scm. + +@node Bibliography, Invoking SCM, SCM Authors, Overview +@section Bibliography + +@table @asis +@item [IEEE] +@pindex IEEE +@cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme +Programming Language.} IEEE, New York, 1991. + +@item [Simply] +@pindex Simply +Brian Harvey and Matthew Wright. +@ifset html +<A HREF="http://HTTP.CS.Berkeley.EDU/~bh/simply-toc.html"> +@end ifset +@cite{Simply Scheme: Introducing Computer Science} +@ifset html +</A> +@end ifset +MIT Press, 1994 ISBN 0-262-08226-8 + +@item [SICP] +@pindex SICP +Harold Abelson and Gerald Jay Sussman with Julie Sussman. +@cite{Structure and Interpretation of Computer Programs.} +MIT Press, Cambridge, 1985. + +@item [R4RS] +@pindex R4RS +William Clinger and Jonathan Rees, Editors. +@ifset html +<A HREF="r4rs_toc.html"> +@end ifset +Revised(4) Report on the Algorithmic Language Scheme. +@ifset html +</A> +@end ifset +@cite{ACM Lisp Pointers} Volume IV, Number 3 (July-September 1991), +pp. 1-55. +@ifinfo + +@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language +Scheme}. +@end ifinfo + +@item [GUILE] +@pindex GUILE +Tom Lord. +@ifset html +<A HREF="http://www.cygnus.com/library/ctr/guile.html"> +@end ifset +The Guile Architecture for Ubiquitous Computing. +@ifset html +</A> +@end ifset +@cite{Usenix Symposium on Tcl/Tk}, 1995. + +@item [SLIB] +@pindex SLIB +Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. +@ifset html +<A HREF="slib_toc.html"> +@end ifset +SLIB, The Portable Scheme Library. +@ifset html +</A> +@end ifset +Version 2a3, June 1995. +@ifinfo + +@ref{Top, , , slib, SLIB}. +@end ifinfo + +@item [JACAL] +@pindex JACAL +Aubrey Jaffer. +@ifset html +<A HREF="jacal_toc.html"> +@end ifset +JACAL Symbolic Mathematics System. +@ifset html +</A> +@end ifset +Version 1a5, April 1994. +@ifinfo + +@ref{Top, , , jacal, JACAL}. +@end ifinfo +@end table + +@table @file +@item scm.texi +@itemx scm.info +Documentation of @code{scm} extensions (beyond Scheme standards). +Documentation on the internal representation and how to extend or +include @code{scm} in other programs. +@end table + +@node Invoking SCM, SCM Options, Bibliography, Overview +@section Invoking SCM + +@quotation +@exdent @b{ scm } [-a @i{kbytes}] [-ibvqmu] [-p @i{number}] +@w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-f @i{filename}]} +@w{[-l @i{filename}]} @w{[-r @i{feature}]} @w{[-- | - | -s]} +@w{[@i{filename}]} @w{[@i{arguments} @dots{}]} +@end quotation + +@noindent +Upon startup @code{scm} loads the file specified by by the environment +variable @var{SCM_INIT_PATH}. + +@noindent +If @var{SCM_INIT_PATH} is not defined or if the file it names is not +present, @code{scm} tries to find the directory containing the +executable file. If it is able to locate the executable, @code{scm} +looks for the initialization file (usually @file{Init.scm}) in +platform-dependent directories relative to this directory. +@xref{File-System Habitat} for a blow-by-blow description. + +@noindent +As a last resort (if initialization file cannot be located), the C +compile parameter @var{IMPLINIT} (defined in the makefile or +@file{scmfig.h}) is tried. + +@noindent +Unless the option @code{-no-init-file} or @code{--no-init-file} occurs +in the command line, @file{Init.scm} checks to see if there is file +@file{ScmInit.scm} in the path specified by the environment variable +@var{HOME} (or in the current directory if @var{HOME} is undefined). If +it finds such a file it is loaded. + +@noindent +@file{Init.scm} then looks for command input from one of three sources: +From an option on the command line, from a file named on the command +line, or from standard input. + +@noindent +This explanation applies to SCMLIT or other builds of SCM. + +@noindent +Scheme-code files can also invoke SCM and its variants. @xref{Syntax +Extensions, #!}. + +@node SCM Options, SCM Variables, Invoking SCM, Overview +@section Options + +@noindent +The options are processed in the order specified on the command line. + +@deffn {Command Option} -a kb +specifies that @code{scm} should allocate an initial heapsize of +@var{kb} kilobytes. This option, if present, must be the first on +the command line. If not specified, the default is +@code{INIT_HEAP_SIZE} in source file @file{setjump.h} which the +distribution sets at @code{25000*sizeof(cell)}. +@end deffn + +@deffn {Command Option} -no-init-file +@deffnx {Command Option} --no-init-file +Inhibits the loading of @file{ScmInit.scm} as described above. +@end deffn + +@deffn {Command Option} -e expression +@deffnx {Command Option} -c expression +specifies that the scheme expression @var{expression} is to be +evaluated. These options are inspired by @code{perl} and @code{sh} +respectively. On Amiga systems the entire option and argument need to be +enclosed in quotes. For instance @samp{"-e(newline)"}. +@end deffn + +@deffn {Command Option} -r feature +requires @var{feature}. This will load a file from [SLIB] if that +@var{feature} is not already supported. If @var{feature} is 2, 3, 4, or +5 @code{scm} will require the features neccessary to support [R2RS], +[R3RS], [R4RS], or proposed [R5RS], respectively. +@end deffn + +@deffn {Command Option} -l filename +@deffnx {Command Option} -f filename +loads @var{filename}. @code{Scm} will load the first (unoptioned) file +named on the command line if no @code{-c}, @code{-e}, @code{-f}, +@code{-l}, or @code{-s} option preceeds +it. +@end deffn + +@deffn {Command Option} -p level +sets the prolixity (verboseness) to @var{level}. This is the same as +the @code{scm} command (verobse @var{level}). +@end deffn + +@deffn {Command Option} -v +(verbose mode) specifies that @code{scm} will print prompts, evaluation +times, notice of loading files, and garbage collection statistics. This +is the same as @code{-p3}. +@end deffn + +@deffn {Command Option} -q +(quiet mode) specifies that @code{scm} will print no extra +information. This is the same as @code{-p0}. +@end deffn + +@deffn {Command Option} -m +specifies that subsequent loads, evaluations, and user interactions will +be with [R4RS] macro capability. To use a specific [R4RS] macro +implementation from [SLIB] (instead of [SLIB]'s default) put @code{-r} +@var{macropackage} before @code{-m} on the command line. +@end deffn + +@deffn {Command Option} -u +specifies that subsequent loads, evaluations, and user interactions will +be without [R4RS] macro capability. [R4RS] macro capability can +be restored by a subsequent @code{-m} on the command line or from Scheme +code. +@end deffn + +@deffn {Command Option} -i +specifies that @code{scm} should run interactively. That means that +@code{scm} will not terminate until the @code{(quit)} or @code{(exit)} +command is given, even if there are errors. It also sets the prolixity +level to 2 if it is less than 2. This will print prompts, evaluation +times, and notice of loading files. The prolixity level can be set by +subsequent options. If @code{scm} is started from a tty, it will assume +that it should be interactive unless given a subsequent @code{-b} +option. +@end deffn + +@deffn {Command Option} -b +specifies that @code{scm} should run non-interactively. That means that +@code{scm} will terminate after processing the command line or if there +are errors. +@end deffn + +@deffn {Command Option} -s +specifies, by analogy with @code{sh}, that further options are to be +treated as program aguments. +@end deffn + +@deffn {Command Option} - +@deffnx {Command Option} -- +specifies that there are no more options on the command line. +@end deffn + +@deffn {Command Option} -d filename +loads SLIB database-utilities and opens @var{filename} as a database. +@end deffn + +@deffn {Command Option} -o filename +saves the current SCM session as the executable program @file{filename}. +This option works only in SCM builds supporting @code{dump} +(@pxref{Dump}). + +If options appear on the command line after @samp{-o @var{filename}}, +then the saved session will continue with processing those options when +it is invoked. Otherwise the (new) command line is processed as usual +when the saved image is invoked. +@end deffn + +@deffn {Command Option} --help +prints usage information and URL; then exit. +@end deffn + +@deffn {Command Option} --version +prints version information and exit. +@end deffn + +@node SCM Variables, SCM Examples, SCM Options, Overview +@section Environment Variables + +@defvr {Environment Variable} SCM_INIT_PATH +is the pathname where @code{scm} will look for its initialization +code. The default is the file @file{Init.scm} in the source directory. +@end defvr + +@defvr {Environment Variable} SCHEME_LIBRARY_PATH +is the [SLIB] Scheme library directory. +@end defvr + +@defvr {Environment Variable} HOME +is the directory where @file{Init.scm} will look for the user +initialization file @file{ScmInit.scm}. +@end defvr + +@section Scheme Variables + +@defvar *argv* +contains the list of arguments to the program. @code{*argv*} can change +during argument processing. This list is suitable for use as an argument +to [SLIB] @code{getopt}. +@end defvar + +@defvar *R4RS-macro* +controls whether loading and interaction support [R4RS] macros. Define +this in @file{ScmInit.scm} or files specified on the command line. This +can be overridden by subsequent @code{-m} and @code{-u} options. +@end defvar + +@defvar *interactive* +controls interactivity as explained for the @code{-i} and @code{-b} +options. Define this in @file{ScmInit.scm} or files specified on the +command line. This can be overridden by subsequent @code{-i} and +@code{-b} options. +@end defvar + +@node SCM Examples, SCM Session, SCM Variables, Overview +@section Examples + +@table @code +@item % scm foo.scm +Loads and executes the contents of @file{foo.scm} and then enters +interactive session. + +@item % scm -f foo.scm arg1 arg2 arg3 +Parameters @code{arg1}, @code{arg2}, and @code{arg3} are stored in the +global list @code{*argv*}; Loads and executes the contents of +@file{foo.scm} and exits. + +@item % scm -s foo.scm arg1 arg2 +Sets *argv* to @code{("foo.scm" "arg1" "arg2")} and enters interactive +session. + +@item % scm -e `(write (list-ref *argv* *optind*))' bar +Prints @samp{"bar"}. + +@item % scm -rpretty-print -r format -i +Loads @code{pretty-print} and @code{format} and enters interactive +session. + +@item % scm -r5 +Loads @code{dynamic-wind}, @code{values}, and [R4RS] macros and enters +interactive (with macros) session. + +@item % scm -r5 -r4 +Like above but @code{rev4-optional-procedures} are also loaded. +@end table + +@node SCM Session, Editing Scheme Code, SCM Examples, Overview +@section SCM Session + +@itemize @bullet +@item +Options, file loading and features can be specified from the command +line. @xref{System interface, , , scm, SCM}. @xref{Require, , , slib, +SLIB}. +@item +Typing the end-of-file character at the top level session (while SCM is +not waiting for parenthesis closure) causes SCM to exit. +@item +Typing the interrupt character aborts evaluation of the current form +and resumes the top level read-eval-print loop. +@end itemize + +@node Editing Scheme Code, Debugging Scheme Code, SCM Session, Overview +@section Editing Scheme Code + +@table @asis +@item Gnu Emacs: +Editing of Scheme code is supported by emacs. Buffers holding files +ending in .scm are automatically put into scheme-mode. + +If your Emacs can run a process in a buffer you can use the Emacs +command @samp{M-x run-scheme} with SCM. However, the run-scheme +(@file{xscheme.el}) which comes included with Gnu Emacs 18 will work +only with MIT Cscheme. If you are using Emacs 18, get the emacs +packages: + +@ifclear html +@itemize @bullet +@item +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el +@item +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el +@end itemize +@end ifclear + +@ifset html +<A HREF="file://ftp-swiss.ai.mit.edu/pub/scheme-editor-packages/cmuscheme.el"> +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el +</A> +<A HREF="file://ftp-swiss.ai.mit.edu/pub/scheme-editor-packages/comint.el"> +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el +</A> +@end ifset + +These files are already standard in Emacs 19. + +If your Emacs can not run a process in a buffer, see ``under other +systems'' below. + +@item Epsilon (MS-DOS): +There is lisp (and scheme) mode available by use of the package +@samp{LISP.E}. It offers several different indentation formats. With +this package, buffers holding files ending in @samp{.L}, @samp{.LSP}, +@samp{.S}, and @samp{.SCM} (my modification) are automatically put into +lisp-mode. + +It is possible to run a process in a buffer under Epsilon. With Epsilon +5.0 the command line options @samp{-e512 -m0} are neccessary to manage +RAM properly. It has been reported that when compiling SCM with Turbo +C, you need to @samp{#define NOSETBUF} for proper operation in a process +buffer with Epsilon 5.0. + +One can also call out to an editor from SCM if RAM is at a premium; See +``under other systems'' below. + +@item other systems: +Define the environment variable @samp{EDITOR} to be the name of the +editing program you use. The SCM procedure @code{(ed arg1 @dots{})} +will invoke your editor and return to SCM when you exit the editor. The +following definition is convenient: + +@example +(define (e) (ed "work.scm") (load "work.scm")) +@end example + +Typing @samp{(e)} will invoke the editor with the file of interest. +After editing, the modified file will be loaded. +@end table + +@node Debugging Scheme Code, , Editing Scheme Code, Overview +@section Debugging Scheme Code + +@noindent +The @code{cautious} and @code{stack-limit} options of @code{build} +(@pxref{Build Options}) support debugging in Scheme. + +@table @dfn +@item CAUTIOUS +If SCM is built with the @samp{CAUTIOUS} flag, then when an error +occurs, a @dfn{stack trace} of certain pending calls are printed as part +of the default error response. A (memoized) expression and newline are +printed for each partially evaluated combination whose procedure is not +builtin. @xref{Memoized Expressions} for how to read memoized +expressions. + +Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and +@code{user-interrupt} (invoked by @key{C-c}) to print stack traces and +conclude by calling @code{breakpoint} (@pxref{Breakpoints, , , slib, +SLIB}) instead of aborting to top level. Under either condition, +program execution can be resumed by @code{(continue)}. + +In this configuration one can interrupt a running Scheme program with +@key{C-c}, inspect or modify top-level values, trace or untrace +procedures, and continue execution with @code{(continue)}. + +@item STACK_LIMIT +If SCM is built with the @samp{STACK_LIMIT} flag, the interpreter will +check stack size periodically. If the size of stack exceeds a certain +amount (default is @code{HEAP_SEG_SIZE/2}), SCM generates a +@code{segment violation} interrupt. + +The usefulness of @samp{STACK_LIMIT} depends on the user. I don't use +it; but the user I added this feature for got primarily this type of +error. +@end table + +@noindent +There are several SLIB macros which so useful that SCM automatically +loads the appropriate module from SLIB if they are invoked. + +@defmac trace proc1 @dots{} +Traces the top-level named procedures given as arguments. +@defmacx trace +With no arguments, makes sure that all the currently traced identifiers +are traced (even if those identifiers have been redefined) and returns a +list of the traced identifiers. +@end defmac + +@defmac untrace proc1 @dots{} +Turns tracing off for its arguments. +@defmacx untrace +With no arguments, untraces all currently traced identifiers and returns +a list of these formerly traced identifiers. +@end defmac + +The routine I use most for debugging is: + +@deffn Procedure print arg1 ... +@code{Print} writes all its arguments, separated by spaces. +@code{Print} outputs a @code{newline} at the end and returns the value +of the last argument. + +One can just insert @samp{(print '<proc-name>} and @samp{)} around an +expression in order to see its value as a program operates. +@end deffn + +@noindent +Sometimes more elaborate measures are needed to print values in a useful +manner. When the values to be printed may have very large (or infinite) +external representations, @ref{Quick Print, , , slib, SLIB}, can be +used. + +When @code{trace} is not sufficient to find program flow problems, +@ifset html +<A HREF="http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html"> +@end ifset +SLIB-PSD, the Portable Scheme Debugger +@ifset html +</A> +@end ifset +offers source code debugging from +GNU Emacs. PSD runs slowly, so start by instrumenting only a few +functions at a time. +@lisp +ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz +prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz +ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz +ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz +@end lisp + + +@node Installing SCM, The Language, Overview, Top +@chapter Installing SCM + +@menu +* File-System Habitat:: All the usual suspects. +* Executable Pathname:: Where did I come from? +* Making SCM:: +* Building SCM:: +* SLIB:: REQUIREd reading. +* Installing Dynamic Linking:: +* Saving Images:: Make Fast-Booting Executables +* Automatic C Preprocessor Definitions:: +* Problems Compiling:: +* Problems Linking:: +* Problems Running:: +* Testing:: +* Reporting Problems:: +@end menu + +@node File-System Habitat, Executable Pathname, Installing SCM, Installing SCM +@section File-System Habitat + +@noindent +Where should software reside? Although individually a minor annoyance, +cumulatively this question represents many thousands of frustrated user +hours spent trying to find support files or guessing where packages need +to be installed. Even simple programs require proper habitat; games +need to find their score files. + +@noindent +Aren't there standards for this? Some Operating Systems have devised +regimes of software habitats -- only to have them violated by large +software packages and imports from other OS varieties. + +@noindent +In some programs, the expected locations of support files are fixed at +time of compilation. This means that the program may not run on +configurations unanticipated by the authors. Compiling locations into a +program also can make it immovable -- necessitating recompilation to +install it. + +@quotation +Programs of the world unite! You have nothing to lose but loss itself. +@end quotation + +@noindent +The function @code{scm_find_impl_file} in @file{scm.c} is an attempt to +create a utility (for inclusion in programs) which will hide the details +of platform-dependent file habitat conventions. It takes as input the +pathname of the executable file which is running. If there are systems +for which this information is either not available or unrelated to the +locations of support files, then a higher level interface will be +needed. + +@deftypefun char *scm_find_impl_file(char *@var{exec_path}, char +*@var{generic_name}, char *@var{initname}, char *@var{sep}) Given the +pathname of this executable (@var{exec_path}), test for the existence of +@var{initname} in the implementation-vicinity of this program. Return a +newly allocated string of the path if successful, 0 if not. The +@var{sep} argument is a @emph{mull-terminated string} of the character +used to separate directory components. +@end deftypefun + +@itemize @bullet +@item +One convention is to install the support files for an executable program +in the same directory as the program. This possibility is tried first, +which satisfies not only programs using this convention, but also +uninstalled builds when testing new releases, etc. + +@item +Another convention is to install the executables in a directory named +@file{bin}, @file{BIN}, @file{exe}, or @file{EXE} and support files in a +directroy named @file{lib}, which is a peer the executable directory. +This arrangement allows multiple executables can be stored in a single +directory. For example, the executable might be in +@samp{/usr/local/bin/} and initialization file in +@samp{/usr/local/lib/}. + +If the executable directory name matches, the peer directroy @file{lib} +is tested for @var{initname}. + +@item +Sometimes @file{lib} directories become too crowded. So we look in any +subdirectories of @file{lib} or @file{src} having the name (sans type +suffix such as @samp{.EXE}) of the program we are running. For example, +the executable might be @samp{/usr/local/bin/foo} and initialization +file in @samp{/usr/local/lib/foo/}. + +@item +But the executable name may not be the usual program name; So also look +in any @var{generic_name} subdirectories of @file{lib} or @file{src} +peers. + +@item +Finally, if the name of the executable file being run has a (system +dependent) suffix which is not needed to invoke the program, then look +in a subdirectory (of the one containing the executable file) named for +the executable (without the suffix); And look in a @var{generic_name} +subdirectory. For example, the executable might be +@samp{C:\foo\bar.exe} and the initialization file in @samp{C:\foo\bar\}. +@end itemize + + +@node Executable Pathname, Making SCM, File-System Habitat, Installing SCM +@section Executable Pathname + +@noindent +When a program is executed by MS-DOS, the full pathname of that +executable is available in @code{argv[0]}. This value can be passed to +@code{dld_find_executable} (@pxref{File-System Habitat}). + +In order to find the habitat for a unix program, we first need to know +the full pathname for the associated executable file. + +@deftypefun char *dld_find_executable (const char *@var{command}) +@code{dld_find_executable} returns the absolute path name of the file +that would be executed if @var{command} were given as a command. It +looks up the environment variable @var{PATH}, searches in each of the +directory listed for @var{command}, and returns the absolute path name +for the first occurrence. Thus, it is advisable to invoke +@code{dld_init} as: + +@example +main (int argc, char **argv) +@{ + @dots{} + if (dld_init (dld_find_executable (argv[0]))) @{ + @dots{} + @} + @dots{} +@} +@end example + +@quotation +@strong{Note:} If the current process is executed using the +@code{execve} call without passing the correct path name as argument 0, +@code{dld_find_executable (argv[0]) } will also fail to locate the +executable file. +@end quotation + +@code{dld_find_executable} returns zero if @code{command} is not found +in any of the directories listed in @code{PATH}. +@end deftypefun + +@node Making SCM, Building SCM, Executable Pathname, Installing SCM +@section Making SCM + +The SCM distribution has @dfn{Makefile} which contains rules for making +@dfn{scmlit}, a ``bare-bones'' version of SCM sufficient for running +@file{build.scm}. @file{build.scm} is used to compile (or create +scripts to compile) full featured versions. + +Makefiles are not portable to the majority of platforms. If +@file{Makefile} works for you, good; If not, I don't want to hear about +it. If you need to compile SCM without build.scm, there are several +ways to proceed: + +@itemize @bullet +@item +Use SCM on a different platform to run @file{build.scm} to create a +script to build SCM; + +@item +Use another implementation of Scheme to run @file{build.scm} to create a +script to build SCM; + +@item +Create your own script or @file{Makefile}. + +@item +Buy a SCM executable from jaffer@@ai.mit.edu. See the end of the +@file{ANNOUNCE} file in the distribution for details. + +@item +Use scmconfig (From: bos@@scrg.cs.tcd.ie): + +Build and install scripts using GNU @dfn{autoconf} are available from +@file{scmconfig4e6.tar.gz} in the distribution directories. See +@file{README.unix} in @file{scmconfig4e6.tar.gz} for further +instructions. +@end itemize + + +@node Building SCM, SLIB, Making SCM, Installing SCM +@section Building SCM + +The file @dfn{build.scm} builds and runs a relational database of how to +compile and link SCM executables. It has information for most platforms +which SCM has been ported to (of which I have been notified). Some of +this information is old, incorrect, or incomplete. Send corrections and +additions to jaffer@@ai.mit.edu. + +@menu +* Invoking Build:: +* Build Options:: +@end menu + +@node Invoking Build, Build Options, Building SCM, Building SCM +@subsection Invoking Build + +The @emph{all} method will also work for MS-DOS and unix. Use +the @emph{all} method if you encounter problems with @file{build.scm}. + +@table @asis +@item MS-DOS +From the SCM source directory, type @samp{build} followed by up to 9 +command line arguments. + +@item unix +From the SCM source directory, type @samp{build.scm} followed by command +line arguments. + +@item @emph{all} +From the SCM source directory, start @samp{scm} or @samp{scmlit} and +type @code{(load "build.scm")}. Alternatively, start @samp{scm} or +@samp{scmlit} with the command line argument @samp{-ilbuild}. + +@end table + +@node Build Options, , Invoking Build, Building SCM +@subsection Build Options + +@noindent +The options to @dfn{build} specify what, where, and how to build a SCM +program or dynamically linked module. These options are unrelated to +the SCM command line options. + +@deffn {Build Option} -p @var{platform-name} +@deffnx {Build Option} ---platform=@var{platform-name} +specifies that the compilation should be for a computer/operating-system +combination called @var{platform-name}. @emph{Note:} The case of +@var{platform-name} is distinguised. The current @var{platform-name}s +are all lower-case. + +The platforms defined by table @dfn{platform} in @file{build.scm} are: +@end deffn +@example +name processor operating-system compiler +symbol processor-family operating-system symbol +symbol atom symbol symbol +================= ================= ================= ================= +*unknown* *unknown* unix *unknown* +acorn-unixlib acorn *unknown* *unknown* +aix powerpc aix *unknown* +amiga-aztec m68000 amiga aztec +amiga-dice-c m68000 amiga dice-c +amiga-sas/c-5.10 m68000 amiga sas/c +atari-st-gcc m68000 atari.st gcc +atari-st-turbo-c m68000 atari.st turbo-c +borland-c-3.1 8086 ms-dos borland-c +djgpp i386 ms-dos gcc +gcc *unknown* unix gcc +highc.31 i386 ms-dos highc +hp-ux hp-risc hp-ux *unknown* +linux i386 linux gcc +linux-elf i386 linux gcc +microsoft-c 8086 ms-dos microsoft-c +microsoft-c-nt i386 ms-dos microsoft-c +microsoft-quick-c 8086 ms-dos microsoft-quick-c +ms-dos 8086 ms-dos *unknown* +os/2-cset i386 os/2 c-set++ +os/2-emx i386 os/2 gcc +sun sparc sun-os *unknown* +svr4 *unknown* unix *unknown* +turbo-c-2 8086 ms-dos turbo-c +unicos cray unicos *unknown* +unix *unknown* unix *unknown* +vms vax vms *unknown* +vms-gcc vax vms gcc +watcom-9.0 i386 ms-dos watcom +@end example + +@deffn {Build Option} -o @var{filename} +@deffnx {Build Option} ---outname=@var{filename} +specifies that the compilation should produce an executable or object +name of @var{filename}. The default is @samp{scm}. Executable suffixes +will be added if neccessary, e.g. @samp{scm} @result{} @samp{scm.exe}. +@end deffn + +@deffn {Build Option} -l @var{libname} @dots{} +@deffnx {Build Option} ---libraries=@var{libname} +specifies that the @var{libname} should be linked with the executable +produced. If compile flags or include directories (@samp{-I}) are +needed, they are automatically supplied for compilations. The @samp{c} +library is always included. SCM @dfn{features} specify any libraries +they need; so you shouldn't need this option often. +@end deffn + +@deffn {Build Option} -D @var{definition} @dots{} +@deffnx {Build Option} ---defines=@var{definition} +specifies that the @var{definition} should be made in any C source +compilations. If compile flags or include directories (@samp{-I}) are +needed, they are automatically supplied for compilations. SCM +@dfn{features} specify any flags they need; so you shouldn't need this +option often. +@end deffn + +@deffn {Build Option} ---compiler-options=@var{flag} +specifies that that @var{flag} will be put on compiler command-lines. +@end deffn + +@deffn {Build Option} ---linker-options=@var{flag} +specifies that that @var{flag} will be put on linker command-lines. +@end deffn + +@deffn {Build Option} -s @var{pathname} +@deffnx {Build Option} ---scheme-initial=@var{pathname} +specifies that @var{pathname} should be the default location of the SCM +initialization file @file{Init.scm}. SCM tries several likely locations +before resorting to @var{pathname} (@pxref{File-System Habitat}). +If not specified, the current directory (where build is building) is +used. +@end deffn + +@deffn {Build Option} -c @var{pathname} @dots{} +@deffnx {Build Option} ---c-source-files=@var{pathname} +specifies that the C source files @var{pathname} @dots{} are to be +compiled. +@end deffn + +@deffn {Build Option} -j @var{pathname} @dots{} +@deffnx {Build Option} ---object-files=@var{pathname} +specifies that the object files @var{pathname} @dots{} are to be linked. +@end deffn + +@deffn {Build Option} -i @var{call} @dots{} +@deffnx {Build Option} ---initialization=@var{call} +specifies that the C functions @var{call} @dots{} are to be +invoked during initialization. +@end deffn + +@deffn {Build Option} -t @var{build-what} +@deffnx {Build Option} ---type=@var{build-what} +specifies in general terms what sort of thing to build. The choices +are: +@table @samp +@item exe +executable program. +@item lib +library module. +@item dlls +archived dynamically linked library object files. +@item dll +dynamically linked library object file. +@end table + +The default is to build an executable. +@end deffn + +@deffn {Build Option} -h @var{batch-syntax} +@deffnx {Build Option} --batch-dialect=@var{batch-syntax} +specifies how to build. The default is to create a batch file for the +host system. The SLIB file @file{batch.scm} knows how to create batch +files for: +@itemize @bullet +@item +unix +@item +dos +@item +vms +@item +system + +This option executes the compilation and linking commands through the +use of the @code{system} procedure. +@item +*unknown* + +This option outputs Scheme code. +@end itemize +@end deffn + +@deffn {Build Option} -w @var{batch-filename} +@deffnx {Build Option} --script-name=@var{batch-filename} +specifies where to write the build script. The default is to display it +on @code{(current-output-port)}. +@end deffn + +@deffn {Build Option} -F @var{feature} @dots{} +@deffnx {Build Option} ---features=@var{feature} +specifies to build the given features into the executable. The defined +features are: + +@table @dfn +@item lit +@itemx none +Lightweight -- no features + +@item cautious +Normally, the number of arguments arguments to interpreted closures + (from LAMBDA) are checked if the function part of a form is not a +symbol or only the first time the form is executed if the function part +is a symbol. defining @samp{reckless} disables any checking. If you +want to have SCM always check the number of arguments to interpreted +closures define feature @samp{cautious}. + +@item careful-interrupt-masking +Define this for extra checking of interrupt masking. This is for +debugging C code in @file{sys.c} and @file{repl.c}. + +@item debug +Turns on features @samp{cautious} @samp{careful-interrupt-masking} +@samp{stack-limit} and uses @code{-g} flags for debugging SCM source +code. + +@item reckless +If your scheme code runs without any errors you can disable almost all +error checking by compiling all files with @samp{reckless}. + +@item stack-limit +Use to enable checking for stack overflow. Define value of the C +preprocessor variable @var{STACK_LIMIT} to be the size to which SCM +should allow the stack to grow. STACK_LIMIT should be less than the +maximum size the hardware can support, as not every routine checks the +stack. + +@item bignums +Large precision integers. + +@item arrays +Use if you want arrays, uniform-arrays and uniform-vectors. + +@item array-for-each +array-map! and array-for-each (arrays must also be defined). + +@item inexact +Use if you want floating point numbers. + +@item engineering-notation +Use if you want floats to display in engineering notation (exponents +always multiples of 3) instead of scientific notation. + +@item single-precision-only +Use if you want all inexact real numbers to be single precision. This +only has an effect if SINGLES is also defined (which is the default). +This does not affect complex numbers. + +@item sicp +Use if you want to run code from: + +H. Abelson, G. J. Sussman, and J. Sussman, +Structure and Interpretation of Computer Programs, +The MIT Press, Cambridge, Massachusetts, USA + +@code{(eq? '() '#f)} is the major difference. + +@item rev2-procedures +These procedures were specified in the @cite{Revised^2 Report on Scheme} +but not in @cite{R4RS}. + +@item record +The Record package provides a facility for user to define their own +record data types. See SLIB for documentation. + +@item compiled-closure +Use if you want to use compiled closures. + +@item generalized-c-arguments +@code{make_gsubr} for arbitrary (< 11) arguments to C functions. + +@item tick-interrupts +Use if you want the ticks and ticks-interrupt functions. + +@item i/o-extensions +Commonly available I/O extensions: @dfn{exec}, line I/O, file +positioning, file delete and rename, and directory functions. + +@item turtlegr +@dfn{Turtle} graphics calls for both Borland-C and X11 from +sjm@@ee.tut.fi. + +@item curses +For the @dfn{curses} screen management package. + +@item edit-line +interface to the editline or GNU readline library. + +@item regex +String regular expression matching. + +@item socket +BSD @dfn{socket} interface. + +@item posix +Posix functions available on all @dfn{Unix-like} systems. fork and +process functions, user and group IDs, file permissions, and @dfn{link}. + +@item unix +Those unix features which have not made it into the Posix specs: nice, +acct, lstat, readlink, symlink, mknod and sync. + +@item windows +Microsoft Windows executable. + +@item dynamic-linking +Be able to load compiled files while running. + +@item dump +Convert a running scheme program into an executable file. + +@item heap-can-shrink +Use if you want segments of unused heap to not be freed up after garbage +collection. This may reduce time in GC for *very* large working sets. + +@item cheap-continuations +If you only need straight stack continuations, executables compile with +this feature will run faster and use less storage than not having it. +Machines with unusual stacks @emph{need} this. Also, if you incorporate +new C code into scm which uses VMS system services or library routines +(which need to unwind the stack in an ordrly manner) you may need to +use this feature. + +@item memoize-local-bindings +Saves the interpeter from having to look up local bindings for every +identifier reference + +@end table +@end deffn + +@node SLIB, Installing Dynamic Linking, Building SCM, Installing SCM +@section SLIB + +@noindent +[SLIB] is a portable Scheme library meant to provide compatibility and +utility functions for all standard Scheme implementations. Although +SLIB is not @emph{neccessary} to run SCM, I strongly suggest you obtain +and install it. Bug reports about running SCM without SLIB have very +low priority. SLIB is available from the same sites as SCM: + +@ifclear html +@itemize @bullet +@item +ftp-swiss.ai.mit.edu:/pub/scm/slib2a6.tar.gz +@item +prep.ai.mit.edu:/pub/gnu/jacal/slib2a6.tar.gz +@item +ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz +@item +ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz +@end itemize +@end ifclear + +@ifset html +<A HREF="file://ftp-swiss.ai.mit.edu/pub/scm/slib2a6.tar.gz"> +ftp-swiss.ai.mit.edu:/pub/scm/slib2a6.tar.gz +</A> +<A HREF="file://prep.ai.mit.edu/pub/gnu/jacal/slib2a6.tar.gz"> +prep.ai.mit.edu:/pub/gnu/jacal/slib2a6.tar.gz +</A> +<A HREF="file://ftp.maths.tcd.ie/pub/bosullvn/jacal/slib2a6.tar.gz"> +ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz +</A> +<A HREF="file://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2a6.tar.gz"> +ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2a6.tar.gz +</A> +@end ifset + +@noindent +Unpack SLIB (@samp{tar xzf slib2a6.tar.gz} or @samp{unzip -ao +slib2a6.zip}) in an appropriate directory for your system; both +@code{tar} and @code{unzip} will create the directory @file{slib}. + +@noindent +Then create a file @file{require.scm} in the SCM +@dfn{implementation-vicinity} (this is the same directory as where the +file @file{Init.scm} is installed). @file{require.scm} should have the +contents: + +@example +(define (library-vicinity) "/usr/local/lib/slib/") +(load (in-vicinity (library-vicinity) "require")) +@end example + +@noindent +where the pathname string @file{/usr/local/lib/slib/} is to be replaced +by the pathname into which you installed SLIB. Absolute pathnames are +recommended here; if you use a relative pathname, SLIB can get confused +when the working directory is changed (@pxref{I/O-Extensions, chmod}). +The way to specify a relative pathname is to append it to the +implementation-vicinity, which is absolute: + +@example +(define library-vicinity + (let ((lv (string-append (implementation-vicinity) "../slib/"))) + (lambda () lv))) +(load (in-vicinity (library-vicinity) "require")) +@end example + +@noindent +Alternatively, you can set the (shell) environment variable +@code{SCHEME_LIBRARY_PATH} to the pathname of the SLIB directory +(@pxref{SCM Variables, SCHEME_LIBRARY_PATH, Environment Variables}). If +set, the environment variable overrides @file{require.scm}. Again, +absolute pathnames are recommended. + + +@node Installing Dynamic Linking, Saving Images, SLIB, Installing SCM +@section Installing Dynamic Linking + +@noindent +Dynamic linking has not been ported to all platforms. Operating systems +in the BSD family (a.out binary format) can usually be ported to +@dfn{DLD}. The @dfn{dl} library (@code{#define SUN_DL} for SCM) was a +proposed POSIX standard and may be available on other machines with +@dfn{COFF} binary format. For notes about porting to MS-Windows and +finishing the port to VMS @ref{Finishing Dynamic Linking}. + +@noindent +@dfn{DLD} is a library package of C functions that performs @dfn{dynamic +link editing} on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), +SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It is +available from: + +@ifclear html +@itemize @bullet +@item +prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz +@end itemize +@end ifclear + +@ifset html +<A HREF="ftp://prep.ai.mit.edu/pub/gnu/dld-3.3.tar.gz"> +prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz +</A> +@end ifset + +@noindent +These notes about using libdl on SunOS are from @file{gcc.info}: + +@quotation +On a Sun, linking using GNU CC fails to find a shared library and +reports that the library doesn't exist at all. + +This happens if you are using the GNU linker, because it does only +static linking and looks only for unshared libraries. If you have +a shared library with no unshared counterpart, the GNU linker +won't find anything. + +We hope to make a linker which supports Sun shared libraries, but +please don't ask when it will be finished--we don't know. + +Sun forgot to include a static version of @file{libdl.a} with some +versions of SunOS (mainly 4.1). This results in undefined symbols when +linking static binaries (that is, if you use @samp{-static}). If you +see undefined symbols @samp{_dlclose}, @samp{_dlsym} or @samp{_dlopen} +when linking, compile and link against the file +@file{mit/util/misc/dlsym.c} from the MIT version of X windows. +@end quotation + + +@node Saving Images, Automatic C Preprocessor Definitions, Installing Dynamic Linking, Installing SCM +@section Saving Images + +@noindent +In SCM, the ability to save running program images is called @dfn{dump} +(@pxref{Dump}). In order to make @code{dump} available to SCM, build +with feature @samp{dump}. @code{dump}ed executables are compatible with +dynamic linking. + +@noindent +Most of the code for @dfn{dump} is taken from +@file{emacs-19.34/src/unex*.c}. No modifications to the emacs source +code were required to use @file{unexelf.c}. Dump has not been ported to +all platforms. If @file{unexec.c} or @file{unexelf.c} don't work for +you, try using the appropriate @file{unex*.c} file from emacs. + + + +@node Automatic C Preprocessor Definitions, Problems Compiling, Saving Images, Installing SCM +@section Automatic C Preprocessor Definitions + +These @samp{#defines} are automatically provided by preprocessors of +various C compilers. SCM uses the presence or absence of these +definitions to configure @dfn{include file} locations and aliases for +library functions. If the definition(s) corresponding to your system +type is missing as your system is configured, add @code{-D@var{flag}} to +the compilation command lines or add a @code{#define @var{flag}} line to +@file{scmfig.h} or the beginning of @file{scmfig.h}. + +@example +#define Platforms: +------- ---------- +ARM_ULIB Huw Rogers free unix library for acorn archimedes +AZTEC_C Aztec_C 5.2a +_DCC Dice C on AMIGA +__GNUC__ Gnu CC (and DJGPP) +__EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0 +__HIGHC__ MetaWare High C +__IBMC__ C-Set++ on OS/2 2.1 +_MSC_VER MS VisualC++ 4.2 +MWC Mark Williams C on COHERENT +_QC Microsoft QuickC +__STDC__ ANSI C compliant +__TURBOC__ Turbo C and Borland C +__WATCOMC__ Watcom C on MS-DOS +__ZTC__ Zortech C + +_AIX AIX operating system +AMIGA SAS/C 5.10 or Dice C on AMIGA +atarist ATARI-ST under Gnu CC +GNUDOS DJGPP (obsolete in version 1.08) +__GO32__ DJGPP (future?) +hpux HP-UX +linux Linux +MCH_AMIGA Aztec_c 5.2a on AMIGA +MSDOS Microsoft C 5.10 and 6.00A +__MSDOS__ Turbo C, Borland C, and DJGPP +nosve Control Data NOS/VE +SVR2 System V Revision 2. +THINK_C developement environment for the Macintosh +ultrix VAX with ULTRIX operating system. +unix most Unix and similar systems and DJGPP (!?) +__unix__ Gnu CC and DJGPP +_UNICOS Cray operating system +_Windows Borland C 3.1 compiling for Windows +_WIN32 MS VisualC++ 4.2 under Windows-NT +vms (and VMS) VAX-11 C under VMS. + +hp9000s800 HP RISC processor +__i386__ DJGPP +i386 DJGPP +MULTIMAX Encore computer +pyr Pyramid 9810 processor +sparc SPARC processor +sequent Sequent computer +tahoe CCI Tahoe processor +@end example + +@node Problems Compiling, Problems Linking, Automatic C Preprocessor Definitions, Installing SCM +@section Problems Compiling + +@table @asis +@item FILE: PROBLEM +HOW TO FIX +@item *.c: include file not found +Correct the status of STDC_HEADERS in @file{scmfig.h} + +fix #include statement or add #define for system type to +@file{scmfig.h}. +@item *.c: Function should return a value in @dots{} +@itemx *.c: Parameter '@dots{}' is never used in @dots{} +@itemx *.c: Condition is always false in @dots{} +@itemx *.c: Unreachable code in function @dots{} +Ignore. +@item scm.c: assignment between incompatible types +change SIGRETTYPE in @file{scm.c}. +@item time.c: CLK_TCK redefined +incompatablility between <stdlib.h> and <sys/types.h>. remove +STDC_HEADERS in @file{scmfig.h}. + +edit <sys/types.h> to remove incompatability. +@item subr.c: Possibly incorrect assignment in function lgcd +Ignore. +@item sys.c: statement not reached +@itemx sys.c: constant in conditional expression +ignore +@item sys.c: `???' undeclared, outside of functions +#undef STDC_HEADERS in @file{scmfig.h}. +@item scl.c: syntax error +#define SYSTNAME to your system type in @file{scl.c} (softtype) +@end table + +@node Problems Linking, Problems Running, Problems Compiling, Installing SCM +@section Problems Linking + +@table @asis +@item PROBLEM +HOW TO FIX +@item _sin etc. missing. +uncomment LIBS in makefile +@end table + +@node Problems Running, Testing, Problems Linking, Installing SCM +@section Problems Running + +@table @asis +@item PROBLEM +HOW TO FIX +@item Opening message and then machine crashes. +Change memory model option to C compiler (or makefile). + +Make sure @code{sizet} definition is correct in @file{scmfig.h}. + +Reduce size of HEAP_SEG_SIZE in @file{setjump.h}. +@item Input hangs +#define NOSETBUF +@item ERROR: heap: need larger initial +Need to increase the initial heap allocation using -a<kb> or +INIT_HEAP_SIZE. +@item ERROR: Could not allocate @dots{} +Check @code{sizet} definition. + +Use 32 bit compiler mode. + +Don't try to run as subproccess +@item remove @dots{} in scmfig.h and recompile scm +@itemx add @dots{} in scmfig.h and recompile scm +Do it and recompile files. +@item ERROR: @file{Init.scm} not found +Assign correct IMPLINIT in makefile or @file{scmfig.h} or define +environment variable @code{SCM_INIT_PATH} to be the full pathname of +@file{Init.scm} (@pxref{Installing SCM}). +@item WARNING: require.scm not found +define environment variable @code{SCHEME_LIBRARY_PATH} to be the full +pathname of the scheme library [SLIB] or change @code{library-vicinity} in +@file{Init.scm} to point to library or remove. @xref{Installation, , , slib, +SLIB}. + +Make sure the value of @code{(library-vicinity)} has a trailing file +separator (like @key{/} or @key{\}). +@end table + +@node Testing, Reporting Problems, Problems Running, Installing SCM +@section Testing + +@noindent +Loading @file{r4rstest.scm} in the distribution will run an [R4RS] +conformance test on @code{scm}. + +@example +> (load "r4rstest.scm") +@print{} +;loading "r4rstest.scm" +SECTION(2 1) +SECTION(3 4) + #<primitive-procedure boolean?> + #<primitive-procedure char?> + #<primitive-procedure null?> + #<primitive-procedure number?> +@dots{} +@end example + +@noindent +Loading @file{pi.scm} in the distribution will enable you to compute +digits of pi. + +@example +> (load "pi") +;loading "pi" +;done loading "pi.scm" +;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other +#<unspecified> +> (pi 100 5) +00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 +37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 +70679 +;Evaluation took 550 mSec (60 in gc) 36976 cells work, 1548 bytes other +#<unspecified> +@end example + +@noindent +Loading @file{bench.scm} will compute and display performance statistics +of SCM running @file{pi.scm}. @samp{make bench} or @samp{make benchlit} +appends the performance report to the file @file{BenchLog}, facilitating +tracking effects of changes to SCM on performance. + +@table @asis +@item PROBLEM +HOW TO FIX +@item Runs some and then machine crashes. +See above under machine crashes. +@item Runs some and then ERROR: @dots{} (after a GC has happened) +Remove optimization option to C compiler and recompile. + +@code{#define SHORT_ALIGN} in @file{scmfig.h}. +@item Some symbol names print incorrectly. +Change memory model option to C compiler (or makefile). + +Check that @code{HEAP_SEG_SIZE} fits within @code{sizet}. + +Increase size of @code{HEAP_SEG_SIZE} (or @code{INIT_HEAP_SIZE} if it is +smaller than @code{HEAP_SEG_SIZE}). +@item ERROR: Rogue pointer in Heap. +See above under machine crashes. +@item Newlines don't appear correctly in output files. +Check file mode (define OPEN_@dots{} in @file{Init.scm} +@item Spaces or control characters appear in symbol names +Check character defines in @file{scmfig.h}. +@item Negative numbers turn positive. +Check SRS in @file{scmfig.h}. +@item VMS: Couldn't unwind stack +@itemx VAX: botched longjmp +@code{#define CHEAP_CONTIUATIONS} in @file{scmfig.h}. +@item Sparc(SUN-4) heap is growing out of control +You are experiencing a GC problem peculiar to the Sparc. The problem is +that SCM doesn't know how to clear register windows. Every location +which is not reused still gets marked at GC time. This causes lots of +stuff which should be collected to not be. This will be a problem with +any @emph{conservative} GC until we find what instruction will clear the +register windows. This problem is exacerbated by using lots of +call-with-current-continuations. +@end table + +@node Reporting Problems, , Testing, Installing SCM +@section Reporting Problems + +@noindent +Reported problems and solutions are grouped under Compiling, Linking, +Running, and Testing. If you don't find your problem listed there, you +can send a bug report to @code{jaffer@@ai.mit.edu}. The bug report +should include: + +@enumerate +@item +The version of SCM (printed when SCM is invoked with no arguments). +@item +The type of computer you are using. +@item +The name and version of your computer's operating system. +@item +The values of the environment variables @code{SCM_INIT_PATH} and +@code{SCHEME_LIBRARY_PATH}. +@item +The name and version of your C compiler. +@item +If you are using an executable from a distribution, the name, vendor, +and date of that distribution. In this case, corresponding with the +vendor is recommended. +@end enumerate + +@node The Language, Packages, Installing SCM, Top +@chapter The Language + +This section describes features which are either present in all builds +of SCM or which must be enabled when SCM is compiled. + +@menu +* Standards Compliance:: Links to sections in [R4RS] and [SLIB] +* System Interface:: Like how to exit +* Errors:: +* Memoized Expressions:: What #@@0+1 and #@@? mean +* Internal State:: GC, errors, and diagnostics +* Miscellaneous Procedures:: +* Time:: Both real time and processor time +* Interrupts:: and exceptions +* Process Synchronization:: Because interrupts are preemptive +* Files and Ports:: +* Soft Ports:: Emulate I/O devices +* Syntax Extensions:: and how to Define New Syntax +* Low Level Syntactic Hooks:: +@end menu + +@node Standards Compliance, System Interface, The Language, The Language +@section Standards Compliance + +@noindent +Scm conforms to the +@ifset html +[IEEE], +@end ifset +@cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming +Language.} +@ifclear html +(@pxref{Bibliography}), +@end ifclear +and +@ifset html +[R4RS], <A HREF="r4rs_toc.html"> +@end ifset +@cite{Revised(4) Report on the Algorithmic Language Scheme}. +@ifset html +</A> +@end ifset +@ifinfo +@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language +Scheme}. +@end ifinfo +All the required features of these specifications are supported. +Many of the optional features are supported as well. + +@subheading Optionals of [R4RS] Supported by SCM + +@table @asis +@item two clause @code{if}: @code{(if <test> <consequent>)} +@xref{Conditionals, , , r4rs, Revised(4) Scheme}. +@item @code{let*} +@itemx named @code{let} +@xref{Binding constructs, , , r4rs, Revised(4) Scheme}. +@item @code{do} +@xref{Iteration, , , r4rs, Revised(4) Scheme}. +@item All varieties of @code{define} +@xref{Definitions, , , r4rs, Revised(4) Scheme}. +@item @code{list-tail} +@xref{Pairs and lists, , , r4rs, Revised(4) Scheme}. +@item @code{string-copy} +@itemx @code{string-fill!} +@xref{Strings, , , r4rs, Revised(4) Scheme}. +@item @code{make-vector} of two arguments +@itemx @code{vector-fill!} +@xref{Vectors, , , r4rs, Revised(4) Scheme}. +@item @code{apply} of more than 2 arguments +@xref{Control features, , , r4rs, Revised(4) Scheme}. +@item @code{-} and @code{/} of more than 2 arguments +@itemx @code{exp} +@itemx @code{log} +@itemx @code{sin} +@itemx @code{cos} +@itemx @code{tan} +@itemx @code{asin} +@itemx @code{acos} +@itemx @code{atan} +@itemx @code{sqrt} +@itemx @code{expt} +@itemx @code{make-rectangular} +@itemx @code{make-polar} +@itemx @code{real-part} +@itemx @code{imag-part} +@itemx @code{magnitude} +@itemx @code{angle} +@itemx @code{exact->inexact} +@itemx @code{inexact->exact} +@xref{Numerical operations, , , r4rs, Revised(4) Scheme}. +@item @code{delay} +@itemx @code{force} +@xref{Control features, , , r4rs, Revised(4) Scheme}. +@itemx @code{with-input-from-file} +@itemx @code{with-output-to-file} +@xref{Ports, , , r4rs, Revised(4) Scheme}. +@itemx @code{char-ready?} +@xref{Input, , , r4rs, Revised(4) Scheme}. +@itemx @code{transcript-on} +@itemx @code{transcript-off} +@xref{System interface, , , r4rs, Revised(4) Scheme}. +@end table + +@subheading Optionals of [R4RS] not Supported by SCM + +@table @asis +@item @code{numerator} +@itemx @code{denominator} +@itemx @code{rationalize} +@xref{Numerical operations, , , r4rs, Revised(4) Scheme}. +@item [R4RS] appendix Macros +@xref{Macros, , , r4rs, Revised(4) Scheme}. +@end table + +@subheading [SLIB] Features of SCM and SCMLIT + +@table @code +@item delay +@itemx full-continuation +@itemx ieee-p1178 +@itemx object-hash +@itemx rev4-report +@itemx source +See SLIB file @file{Template.scm}. +@item current-time +@xref{Time, , , slib, SLIB}. +@item defmacro +@xref{Defmacro, , , slib, SLIB}. +@item dynamic-wind +@xref{Dynamic-Wind, , , slib, SLIB}. +@item eval +@xref{System, , , slib, SLIB}. +@item getenv +@itemx system +@xref{System Interface, , , slib, SLIB}. +@item hash +@xref{Hashing, , , slib, SLIB}. +@item logical +@xref{Bit-Twiddling, , , slib, SLIB}. +@item multiarg-apply +@xref{Multi-argument Apply, , , slib, SLIB}. +@item multiarg/and- +@xref{Multi-argument / and -, , , slib, SLIB}. +@item rev4-optional-procedures +@xref{Rev4 Optional Procedures, , , slib, SLIB}. +@item string-port +@xref{String Ports, , , slib, SLIB}. +@item tmpnam +@xref{Input/Output, , , slib, SLIB}. +@item transcript +@xref{Transcripts, , , slib, SLIB}. +@item vicinity +@xref{Vicinity, , , slib, SLIB}. +@item with-file +@xref{With-File, , , slib, SLIB}. +@end table + +@subheading [SLIB] Features of SCM + +@table @code +@item array +@xref{Arrays, , , slib, SLIB}. +@item array-for-each +@xref{Array Mapping, , , slib, SLIB}. +@item bignum +@itemx complex +@itemx inexact +@itemx rational +@itemx real +@xref{Require, , , slib, SLIB}. +@end table + +@node System Interface, Errors, Standards Compliance, The Language +@section System Interface + +@noindent +For documentation of the procedures @code{getenv} and @code{system} +@xref{System Interface, , , slib, SLIB}. + +@defun quit +@defunx quit n +@defunx exit +@defunx exit n +Aliases for @code{exit} (@pxref{System, exit, , slib, SLIB}). On many +systems, SCM can also tail-call another program. @xref{I/O-Extensions, +execp}. +@end defun + +@defun vms-debug +If SCM is compiled under VMS these commands will invoke the editor or +debugger respectively. +@end defun + +@defun ed filename +If SCM is compiled under VMS @code{ed} will invoke the editor with a +single the single argument @var{filename}. + +@defunx ed arg1 @dots{} +Otherwise, the value of the environment variable @code{EDITOR} (or just +@code{ed} if it isn't defined) is invoked as a command with arguments +@var{arg1} @dots{}. +@end defun + +@defun program-arguments +Returns a list of strings of the arguments scm was called with. +@end defun + +@defun errno +@defunx errno n +With no argument returns the current value of the system variable +@code{errno}. When given an argument, @code{errno} sets the system +variable @code{errno} to @var{n} and returns the previous value of +@code{errno}. @code{(errno 0)} will clear outstanding errors. This is +recommended after @code{try-load} returns @code{#f} since this occurs +when the file could not be opened. +@end defun + +@defun perror string +Prints on standard error output the argument @var{string}, a colon, +followed by a space, the error message corresponding to the current +value of @code{errno} and a newline. The value returned is unspecified. +@end defun + +@node Errors, Memoized Expressions, System Interface, The Language +@section Errors + +@noindent +A computer-language implementation designer faces choices of how +reflexive to make the implementation in handling exceptions and errors; +that is, how much of the error and exception routines should be written +in the language itself. The design of a portable implementation is +further constrained by the need to have (almost) all errors print +meaningful messages, even when the implementation itself is not +functioning correctly. Therefore, SCM implements much of its error +response code in C. + +@noindent +The following common error and conditions are handled by C code. Those +with callback names after them can also be handled by Scheme code +(@pxref{Interrupts}). If the callback identifier is not defined at top +level, the default error handler (C code) is invoked. There are many +other error messages which are not treated specially. + +@enumerate 0 +@item +Wrong type in arg 0 +@item +Wrong type in arg 1 +@item +Wrong type in arg 2 +@item +Wrong type in arg 3 +@item +Wrong type in arg 4 +@item +Wrong type in arg 5 +@item +Wrong number of args +@item +numerical overflow +@item +Argument out of range +@item +Could not allocate @code{(out-of-storage)} +@item +EXIT @code{(end-of-program)} +@item +hang up @code{(hang-up)} +@item +user interrupt @code{(user-interrupt)} +@item +arithmetic error @code{(arithmetic-error)} +@item +bus error +@item +segment violation +@item +alarm @code{(alarm-interrupt)} +@end enumerate + +@defvar errobj +If SCM encounters a non-fatal error it aborts evaluation of the current +form, prints a message explaining the error, and resumes the top level +read-eval-print loop. The value of @var{errobj} is the offending object +if appropriate. The builtin procedure @code{error} does @emph{not} set +@var{errobj}. +@end defvar + +@defun error arg1 arg2 arg3 @dots{} +Alias for @ref{System, error, , slib, SLIB}. Outputs an error message +containing the arguments, aborts evaluation of the current form and +resumes the top level read-eval-print loop. Error is defined in +@file{Init.scm}; Feel free to redefine it to suit your purposes. +@end defun + +@subsection CAUTIOUS enhancements + +@noindent +If SCM is built with the @samp{CAUTIOUS} flag, then when an error +occurs, a @dfn{stack trace} of certain pending calls are printed as part +of the default error response. A (memoized) expression and newline are +printed for each partially evaluated combination whose procedure is not +builtin. @xref{Memoized Expressions} for how to read memoized +expressions. + +@noindent +Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and +@code{user-interrupt} (invoked by @key{C-c}) are defined to print stack +traces and conclude by calling @code{breakpoint} (@pxref{Breakpoints, , +, slib, SLIB}). This allows the user to interract with SCM as with Lisp +systems. + +@defun stack-trace +Prints information describing the stack of partially evaluated +expressions. @code{stack-trace} returns @code{#t} if any lines were +printed and @code{#f} otherwise. See @file{Init.scm} for an example of +the use of @code{stack-trace}. +@end defun + +@node Memoized Expressions, Internal State, Errors, The Language +@section Memoized Expressions + +@noindent +SCM memoizes the address of each occurence of an identifier's value when +first encountering it in a source expression. Subsequent executions of +that memoized expression is faster because the memoized reference +encodes where in the top-level or local environment its value is. + +@noindent +When procedures are displayed, the memoized locations appear in a format +different from references which have not yet been executed. I find this +a convenient aid to locating bugs and untested expressions. + +@itemize @bullet +@item +The names of memoized lexically bound identifiers are replaced with +@r{#@@}@i{<m>}@r{-}@i{<n>}, where @i{<m>} is the number of binding +contours back and @i{<n>} is the index of the value in that +binding countour. +@item +The names of identifiers which are not lexiallly bound but defined at +top-level have @r{#@@} prepended. +@end itemize + +@noindent +For instance, @code{open-input-file} is defined as follows in +@file{Init.scm}: + +@example +(define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) +@end example + +@noindent +If @code{open-input-file} has not yet been used, the displayed procedure +is similar to the original definition (lines wrapped for readability): + +@example +open-input-file @result{} +#<CLOSURE (str) (or (open-file str open_read) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))> +@end example + +@noindent +If we open a file using @code{open-input-file}, the sections of code +used become memoized: + +@example +(open-input-file "r4rstest.scm") @result{} #<input-port 3> +open-input-file @result{} +#<CLOSURE (str) (#@@or (#@@open-file #@@0+0 #@@open_read) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))> +@end example + +@noindent +If we cause @code{open-input-file} to execute other sections of code, +they too become memoized: + +@example +(open-input-file "foo.scm") @result{} + +ERROR: No such file or directory +ERROR: OPEN-INPUT-FILE couldn't open file "foo.scm" + +open-input-file @result{} +#<CLOSURE (str) (#@@or (#@@open-file #@@0+0 #@@open_read) + (#@@and (#@@procedure? #@@could-not-open) (could-not-open) #f) + (#@@error "OPEN-INPUT-FILE couldn't open file " #@@0+0))> +@end example + + +@node Internal State, Miscellaneous Procedures, Memoized Expressions, The Language +@section Internal State + +@defvar *interactive* +The variable @var{*interactive*} determines whether the SCM session is +interactive, or should quit after the command line is processed. +@var{*interactive*} is controlled directly by the command-line options +@samp{-b}, @samp{-i}, and @samp{-s} (@pxref{Invoking SCM}). If none of +these options are specified, the rules to determine interactivity are +more complicated; see @file{Init.scm} for details. +@end defvar + +@defun abort +Resumes the top level Read-Eval-Print loop. +@end defun + +@defun restart +Restarts the SCM program with the same arguments as it was originally +invoked. All @samp{-l} loaded files are loaded again; If those files +have changed, those changes will be reflected in the new session. + +@emph{Note:} When running a saved executable (@pxref{Dump}), +@code{restart} is redefined to be @code{exec-self}. +@end defun + +@defun exec-self +Exits and immediately re-invokes the same executable with the same +arguments. If the executable file has been changed or replaced since +the beginning of the current session, the @emph{new} executable will be +invoked. This differentiates @code{exec-self} from @code{restart}. +@end defun + +@defun verbose n +Controls how much monitoring information is printed. +If @var{n} is: + +@table @asis +@item 0 +no prompt or information is printed. +@item >= 1 +a prompt is printed. +@item >= 2 +the CPU time is printed after each top level form evaluated. +@item >= 3 +messages about heap growth are printed. +@item >= 4 +garbage collection (@pxref{Garbage Collection}) messages are printed. +@item >= 5 +a warning will be printed for each top-level symbol which is defined +more than one time. +@end table +@end defun + +@defun gc +Scans all of SCM objects and reclaims for further use those that are +no longer accessible. +@end defun + +@defun room +@defunx room #t +Prints out statistics about SCM's current use of storage. @code{(room #t)} +also gives the hexadecimal heap segment and stack bounds. +@end defun + +@defvr Constant *scm-version* +Contains the version string (e.g. @file{4e6}) of SCM. +@end defvr + +@noindent +For other configuration constants and procedures @xref{Configuration, , +, slib, SLIB}. + +@node Miscellaneous Procedures, Time, Internal State, The Language +@section Miscellaneous Procedures + +@defun try-load filename +If the string @var{filename} names an existing file, the try-load +procedure reads Scheme source code expressions and definitions from the +file and evaluates them sequentially and returns @code{#t}. If not, +try-load returns @code{#f}. The try-load procedure does not affect the +values returned by @code{current-input-port} and +@code{current-output-port}. +@end defun + +@defvar *load-pathname* +Is set to the pathname given as argument to @code{load}, +@code{try-load}, and @code{dyn:link} (@pxref{Compiling And Linking}). +@code{*load-pathname*} is used to compute the value of @ref{Vicinity, +program-vicinity, , slib, SLIB}. +@end defvar + +@defun line-number +Returns the current line number of the file currently being loaded. +@end defun + +@defun eval obj +Alias for @ref{System, eval, , slib, SLIB}. +@end defun + +@defun eval-string str +Returns the result of reading an expression from @var{str} and +evaluating it. @code{eval-string} does not change +@code{*load-pathname*} or @code{line-number}. +@end defun + +@defun load-string str +Reads and evaluates all the expressions from @var{str}. As with +@code{load}, the value returned is unspecified. @code{eval-string} does +not change @code{*load-pathname*} or @code{line-number}. +@end defun + +@defun vector-set-length! object length +Change the length of string, vector, bit-vector, or uniform-array +@var{object} to @var{length}. If this shortens @var{object} then the +remaining contents are lost. If it enlarges @var{object} then the +contents of the extended part are undefined but the original part is +unchanged. It is an error to change the length of literal datums. The +new object is returned. +@end defun + +@defun copy-tree obj +@xref{Tree Operations, copy-tree, , slib, SLIB}. This extends the SLIB +version by also copying vectors. +@end defun + +@defun acons obj1 obj2 obj3 +Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list +(acons key datum a-list)) adds a new association to a-list. +@end defun + +@defun terms +This command displays the GNU General Public License. +@end defun + +@defun list-file filename +Displays the text contents of @var{filename}. +@end defun + +@deffn Procedure print arg1 ... +@code{Print} writes all its arguments, separated by spaces. +@code{Print} outputs a @code{newline} at the end and returns the value +of the last argument. +@end deffn + +@node Time, Interrupts, Miscellaneous Procedures, The Language +@section Time + +@defvr Constant internal-time-units-per-second + +Is the integer number of internal time units in a second. +@end defvr + +@defun get-internal-run-time +Returns the integer run time in internal time units from an unspecified +starting time. The difference of two calls to +@code{get-internal-run-time} divided by +@code{internal-time-units-per-second} will give elapsed run time in +seconds. +@end defun + +@defun get-internal-real-time +Returns the integer time in internal time units from an unspecified +starting time. The difference of two calls to +@code{get-internal-real-time} divided by +@code{interal-time-units-per-second} will give elapsed real time in +seconds. +@end defun + +@defun current-time +Returns the time since 00:00:00 GMT, January 1, 1970, measured in +seconds. @xref{Time, current-time, , slib, SLIB}. @code{current-time} is +used in @ref{Time, , , slib, SLIB}. +@end defun + +@node Interrupts, Process Synchronization, Time, The Language +@section Interrupts + +@defun ticks n +Returns the number of ticks remaining till the next tick interrupt. +Ticks are an arbitrary unit of evaluation. Ticks can vary greatly in +the amount of time they represent. + +If @var{n} is 0, any ticks request is canceled. Otherwise a +@code{ticks-interrupt} will be signaled @var{n} from the current time. +@code{ticks} is supported if SCM is compiled with the @code{ticks} flag +defined. +@end defun + +@deffn {Callback procedure} ticks-interrupt @dots{} +Establishes a response for tick interrupts. Another tick interrupt will +not occur unless @code{ticks} is called again. Program execution will +resume if the handler returns. This procedure should (abort) or some +other action which does not return if it does not want processing to +continue. +@end deffn + +@defun alarm secs +Returns the number of seconds remaining till the next alarm interrupt. +If @var{secs} is 0, any alarm request is canceled. Otherwise an +@code{alarm-interrupt} will be signaled @var{secs} from the current +time. ALARM is not supported on all systems. +@end defun + +@deffn {Callback procedure} user-interrupt @dots{} +@deffnx {Callback procedure} alarm-interrupt @dots{} +Establishes a response for @code{SIGINT} (control-C interrupt) and +@code{SIGALRM} interrupts. Program execution will resume if the handler +returns. This procedure should @code{(abort)} or some other action +which does not return if it does not want processing to continue after +it returns. + +Interrupt handlers are disabled during execution @code{system} and +@code{ed} procedures. + +To unestablish a response for an interrupt set the handler symbol to +@code{#f}. For instance, @code{(set! user-interrupt #f)}. +@end deffn + +@deffn {Callback procedure} out-of-storage @dots{} +@deffnx {Callback procedure} could-not-open @dots{} +@deffnx {Callback procedure} end-of-program @dots{} +@deffnx {Callback procedure} hang-up @dots{} +@deffnx {Callback procedure} arithmetic-error @dots{} +Establishes a response for storage allocation error, file opening +error, end of program, SIGHUP (hang up interrupt) and arithmetic +errors respectively. This procedure should (abort) or some other +action which does not return if it does not want the default error +message to also be displayed. If no procedure is defined for @var{hang-up} +then @var{end-of-program} (if defined) will be called. + +To unestablish a response for an error set the handler symbol to +@code{#f}. For instance, @code{(set! could-not-open #f)}. +@end deffn + +@node Process Synchronization, Files and Ports, Interrupts, The Language +@section Process Synchronization + +@defun make-arbiter name + +Returns an object of type arbiter and name @var{name}. Its state is +initially unlocked. +@end defun + +@defun try-arbiter arbiter + +Returns @code{#t} and locks @var{arbiter} if @var{arbiter} was unlocked. +Otherwise, returns @code{#f}. +@end defun + +@defun release-arbiter arbiter + +Returns @code{#t} and unlocks @var{arbiter} if @var{arbiter} was locked. +Otherwise, returns @code{#f}. +@end defun + +@node Files and Ports, Soft Ports, Process Synchronization, The Language +@section Files and Ports + +@noindent +These procedures generalize and extend the standard capabilities in +@ref{Ports, , ,r4rs, Revised(4) Scheme}. + +@defun open-file string modes +Returns a port capable of receiving or delivering characters as +specified by the @var{modes} string. If a file cannot be opened +@code{#f} is returned. +@end defun + +@defvr Constant open_read +@defvrx Constant open_write +@defvrx Constant open_both +Contain modes strings specifying that a file is to be opened for +reading, writing, and both reading and writing respectively. +@end defvr + +@defun _ionbf modestr +Returns a version of modestr which when open-file is called with it as +the second argument will return an unbuffered port. A non-file +input-port must be unbuffered in order for char-ready? to work correctly +on it. The initial value of (current-input-port) is unbuffered if the +platform supports it. +@end defun + +@defun close-port port +Closes @var{port}. The same as close-input-port and close-output-port. +@end defun + +@defun open-io-file filename +@defunx close-io-port port +These functions are analogous to the standard scheme file functions. +The ports are open to @var{filename} in read/write mode. Both input and +output functions can be used with io-ports. An end of file must be read +or a file-set-position done on the port between a read operation and a +write operation or vice-versa. +@end defun + +@defun current-error-port +Returns the current port to which diagnostic output is directed. +@end defun + +@defun with-error-to-file string thunk +@var{thunk} must be a procedure of no arguments, and string must be a +string naming a file. The file is opened for output, an output port +connected to it is made the default value returned by +current-error-port, and the @var{thunk} is called with no arguments. When +the thunk returns, the port is closed and the previous default is +restored. With-error-to-file returns the value yielded by @var{thunk}. +@end defun + +@defun with-input-from-port port thunk +@defunx with-output-to-port port thunk +@defunx with-error-to-port port thunk +These routines differ from with-input-from-file, with-output-to-file, +and with-error-to-file in that the first argument is a port, rather +than a string naming a file. +@end defun + +@deffn {procedure} char-ready? +@deffnx {procedure} char-ready? port + +Returns @code{#t} if a character is ready on the input @var{port} and +returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t} +then +@findex char-ready +the next @code{read-char} operation on the given @var{port} is +guaranteed +@findex read-char +not to hang. If the @var{port} is at end of file then +@code{char-ready?} returns @code{#t}. +@findex char-ready? +@var{Port} may be omitted, in which case it defaults to +the value returned by @code{current-input-port}. +@findex current-input-port + +@emph{Rationale:} @code{Char-ready?} exists to make it possible for a program to +@findex char-ready? +accept characters from interactive ports without getting stuck waiting +for input. Any input editors associated with such ports must ensure +that characters whose existence has been asserted by @code{char-ready?} +@findex char-ready? +cannot be rubbed out. If @code{char-ready?} were to return @code{#f} at +end of file, a port at end of file would be indistinguishable from an +interactive port that has no ready characters. +@c end rationale +@end deffn + + +@node Soft Ports, Syntax Extensions, Files and Ports, The Language +@section Soft Ports + +@noindent +A @dfn{soft-port} is a port based on a vector of procedures capable of +accepting or delivering characters. It allows emulation of I/O ports. + +@defun make-soft-port vector modes +Returns a port capable of receiving or delivering characters as +specified by the @var{modes} string (@pxref{Files and Ports, +open-file}). @var{vector} must be a vector of length 6. Its components +are as follows: + +@enumerate 0 +@item +procedure accepting one character for output +@item +procedure accepting a string for output +@item +thunk for flushing output +@item +thunk for getting one character +@item +thunk for closing port (not by garbage collection) +@end enumerate + +For an output-only port only elements 0, 1, 2, and 4 need be +procedures. For an input-only port only elements 3 and 4 need be +procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful +operation for them to perform. + +If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input, +eof-object?, ,r4rs, Revised(4) Scheme}) it indicates that the port has +reached end-of-file. For example: + +@example +(define stdout (current-output-port)) +(define p (make-soft-port + (vector + (lambda (c) (write c stdout)) + (lambda (s) (display s stdout)) + (lambda () (display "." stdout)) + (lambda () (char-upcase (read-char))) + (lambda () (display "@@" stdout))) + "rw")) + +(write p p) @result{} #<input-output-soft#\space45d10#\> +@end example +@end defun + +@node Syntax Extensions, Low Level Syntactic Hooks, Soft Ports, The Language +@section Syntax Extensions + +@deffn {Read syntax} #. expression +Is read as the object resulting from the evaluation of @var{expression}. +This substitution occurs even inside quoted structure. + +In order to allow compiled code to work with @code{#.} it is good +practice to define those symbols used inside of @var{expression} with +@code{#.(define @dots{})}. For example: + +@example +#.(define foo 9) @result{} #<unspecified> +'(#.foo #.(+ foo foo)) @result{} (9 18) +@end example +@end deffn + +@deffn {Read syntax} #+ feature form +If feature is @code{provided?} (by @code{*features*}) then @var{form} is +read as a scheme expression. If not, then @var{form} is treated as +whitespace. + +Feature is a boolean expression composed of symbols and @code{and}, +@code{or}, and @code{not} of boolean expressions. + +For more information on @code{provided?} and @code{*features*}, +@xref{Require, , , slib, SLIB}. +@end deffn + +@deffn {Read syntax} #- feature form +is equivalent to @code{#+(not feature) expression}. +@end deffn + +@deffn {Read syntax} #' form +is equivalent to @var{form} (for compatibility with common-lisp). +@end deffn + +@deffn {Read syntax} #| any thing |# +Is a balanced comment. Everything up to the matching @code{|#} is +ignored by the @code{read}. Nested @code{#|@dots{}|#} can occur inside +@var{any thing}. +@end deffn + +@deffn {Read syntax} #! any thing +On the first line of a file will be ignored when loaded by SCM. This +makes SCM files usable as POSIX shell scripts if the first line is: + +@example +#!/usr/local/bin/scm +@end example + +When such a file is invoked it executes /usr/local/bin/scm with the +name of this file as the first argument. The following shell script +will print factorial of its argument: +@example +#!/usr/local/bin/scm +;;; -*-scheme-*- tells emacs this is a scheme file. +(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) +(display (fact (string->number (caddr (program-arguments))))) +(newline) +(quit) +@end example + +This technique has some drawbacks: +@itemize @bullet +@item +Some Unixes limit the length of the @samp{#!} interpreter line to the +size of an object file header, which can be as small as 32 bytes. +@item +A full, explicit pathname must be specified, perhaps requiring more than +32 bytes and making scripts vulnerable to programs being moved. +@end itemize + +The following approach solves both problems -- at the expense of +slightly slower startup. @code{type;} should appear on every line to be +executed by the shell. These lines do not have the length restriction +mentioned above. Also, @code{/bin/sh} searches the directories listed +in the `PATH' environment variable for @samp{scm}, eliminating the need +to know absolute locations in order to invoke a program. +@example +#!/bin/sh +type;exec scm $0 $* +;;; -*-scheme-*- tells emacs this is a scheme file. +(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n))))) +(display (fact (string->number (caddr (program-arguments))))) +(newline) +(quit) +@end example +@end deffn + +@defspec defined? symbol +Equivalent to @code{#t} if @var{symbol} is a syntactic keyword (such as +@code{if}) or a symbol with a value in the top level environment +(@pxref{Variables and regions, , ,r4rs, Revised(4) Scheme}). Otherwise +equivalent to @code{#f}. +@end defspec + +@defspec defvar identifier initial-value +If @var{identifier} is unbound in the top level environment, then +@var{identifier} is @code{define}d to the result of evaluating the form +@var{initial-value} as if the @code{defvar} form were instead the form +@code{(define identifier initial-value)} . If @var{identifier} already +has a value, then @var{initial-value} is @emph{not} evaluated and +@var{identifier}'s value is not changed. +@end defspec + +@noindent +SCM also supports the following constructs from Common Lisp: +@code{defmacro}, @code{macroexpand}, @code{macroexpand-1}, and +@code{gentemp}. @xref{Defmacro, , , slib, SLIB}. + + +@node Low Level Syntactic Hooks, , Syntax Extensions, The Language +@section Low Level Syntactic Hooks + +@deffn {Callback procedure} read:sharp c port +If a @key{#} followed by a character (for a non-standard syntax) is +encountered by @code{read}, @code{read} will call the value of the +symbol @code{read:sharp} with arguments the character and the port being +read from. The value returned by this function will be the value of +@code{read} for this expression unless the function returns +@code{#<unspecified>} in which case the expression will be treated as +whitespace. @code{#<unspecified>} is the value returned by the +expression @code{(if #f #f)}. + +@emph{Note:} When adding new @key{#} syntaxes, have your code save the +previous value of @code{read:sharp} when defining it. Call this saved +value if an invocation's syntax is not recognized. This will allow +@code{#+}, @code{#-}, @code{#!}, and @ref{Uniform Array}s to still be +supported (as they use @code{read:sharp}). +@end deffn + +@defun procedure->syntax proc +Returns a @dfn{macro} which, when a symbol defined to this value appears +as the first symbol in an expression, returns the result of applying +@var{proc} to the expression and the environment. +@end defun + +@defun procedure->macro proc +@defunx procedure->memoizing-macro proc +Returns a @dfn{macro} which, when a symbol defined to this value appears +as the first symbol in an expression, evaluates the result of applying +@var{proc} to the expression and the environment. The value returned +from @var{proc} which has been passed to +@code{PROCEDURE->MEMOIZING-MACRO} replaces the form passed to +@var{proc}. For example: + +@example +(define trace + (procedure->macro + (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) + +(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). +@end example + +An @dfn{environment} is a list of @dfn{environment frames}. There are 2 +types of environment frames: + +@table @code +@item ((lambda (variable1 @dots{}) @dots{}) value1 @dots{}) +@itemx (let ((variable1 value1) (variable2 value2) @dots{}) @dots{}) +@itemx (letrec ((variable1 value1) @dots{}) @dots{}) +result in a single enviroment frame: +@example +((variable1 @dots{}) value1 @dots{}) +@end example + +@item (let ((variable1 value1)) @dots{}) +@itemx (let* ((variable1 value1) @dots{}) @dots{}) +result in an environment frame for each variable: +@example +(variable1 . value1) (variable2 . value2) @dots{} +@end example +@end table +@end defun + +@defspec @@apply procedure argument-list +Returns the result of applying procedure to argument-list. (apply +procedure argument-list) will produce the same result. +@end defspec + +@defspec @@call-with-current-continuation procedure) +Returns the result of applying @var{procedure} to the current +continuation. A @dfn{continuation} is a SCM object of type +@code{contin} (@pxref{Continuations}). The procedure +@code{(call-with-current-continuation @var{procedure})} is defined to +have the same effect as @code{(@@call-with-current-continuation +procedure)}. +@end defspec + + +@node Packages, The Implementation, The Language, Top +@chapter Packages + +@menu +* Executable path:: +* Compiling And Linking:: Hobbit and Dynamic Linking +* Dynamic Linking:: +* Dump:: Create Fast-Booting Executables +* Numeric:: Numeric Language Extensions +* Arrays:: As in APL +* I/O-Extensions:: 'i/o-extensions +* Posix Extensions:: 'posix +* Regular Expression Pattern Matching:: 'regex +* Line Editing:: 'edit-line +* Curses:: Screen Control +* Sockets:: Cruise the Net +@end menu + +@node Executable path, Compiling And Linking, Packages, Packages +@section Executable path + +In order to dump a saved executable or to dynamically-link using DLD, +SCM must know where its executable file is. Sometimes SCM +(@pxref{Executable Pathname}) guesses incorrectly the location of the +currently running executable. In that case, the correct path can be set +by calling @code{execpath} with the pathname. + +@defun execpath +Returns the path (string) which SCM uses to find the executable file +whose invocation the currently running session is, or #f if the path is +not set. +@defunx execpath #f +@defunx execpath newpath +Sets the path to @code{#f} or @var{newpath}, respectively. The old path +is returned. +@end defun + +@node Compiling And Linking, Dynamic Linking, Executable path, Packages +@section Compiling And Linking + +@defun compile-file name1 name2 @dots{} +If the HOBBIT compiler is installed in the +@code{(implementation-vicinity)}, compiles the files @var{name1} +@var{name2} @dots{} to an object file name @var{name1}<object-suffix>, +where <object-suffix> is the object file suffix for your computer (for +instance, @file{.o}). @var{name1} must be in the current directory; +@var{name2} @dots{} can be in other directories. +@end defun + +@defun link-named-scm name module1 @dots{} +Creates a new SCM executable with name @var{name}. @var{name} will +include the object modules @var{module1} @dots{} which can be produced +with @code{compile-file}. + +@example +cd ~/scm/ +scm -e'(link-named-scm"cute""cube")' +(delete-file "scmflags.h") +(call-with-output-file + "scmflags.h" + (lambda (fp) + (for-each + (lambda (string) (write-line string fp)) + '("#define IMPLINIT \"/home/jaffer/scm/Init.scm\"" + "#define COMPILED_INITS init_cube();" + "#define BIGNUMS" + "#define FLOATS" + "#define ARRAYS")))) +(system "gcc -Wall -O2 -c continue.c findexec.c time.c + repl.c scl.c eval.c sys.c subr.c unif.c rope.c scm.c") +@dots{} +scm.c: In function `scm_init_extensions': +scm.c:95: warning: implicit declaration of function `init_cube' +scm.c: In function `scm_cat_path': +scm.c:589: warning: implicit declaration of function `realloc' +scm.c:594: warning: implicit declaration of function `malloc' +scm.c: In function `scm_try_path': +scm.c:612: warning: implicit declaration of function `free' +(system "cc -o cute continue.o findexec.o time.o repl.o scl.o + eval.o sys.o subr.o unif.o rope.o scm.o cube.o -lm -lc") + +Compilation finished at Sun Jul 21 00:59:17 +@end example +@end defun + +@node Dynamic Linking, Dump, Compiling And Linking, Packages +@section Dynamic Linking + +@noindent +If SCM has been compiled with @file{dynl.c} then the additional +properties of load and require (from [SLIB]) specified here are +supported. The @code{require} forms are preferred. The variable +@code{*catalog*} can be extended to define other @code{require}-able +packages. See @file{Link.scm} for details. + +@defun load filename lib1 @dots{} +In addition to the [R4RS] requirement of loading Scheme expressions if +@var{filename} is a Scheme source file, @code{load} will also +dynamically load/link object files (produced by @code{compile-file}, for +instance). The object-suffix need not be given to load. For example, + +@example +(load (in-vicinity (implementation-vicinity) "sc2")) +or (load (in-vicinity (implementation-vicinity) "sc2.o")) +or (require 'rev2-procedures) +or (require 'rev3-procedures) +@end example + +will load/link @file{sc2.o} if it exists. + +The @var{lib1} @dots{} pathnames are for additional libraries which may be +needed for object files not produced by the Hobbit compiler. For +instance, crs is linked on Linux by + +@example +(load (in-vicinity (implementation-vicinity) "crs.o") + (usr:lib "ncurses") (usr:lib "c")) +or (require 'curses) +@end example + +Turtlegr graphics library is linked by: + +@example +(load (in-vicinity (implementation-vicinity) "turtlegr") + (usr:lib "X11") (usr:lib "c") (usr:lib "m")) +or (require 'turtle-graphics) +@end example + +And the string regular expression (@pxref{Regular Expression Pattern +Matching}) package is linked by: + +@example +(load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c")) +@end example +or +@example +(require 'regex) +@end example +@end defun + +@defun require 'db +@defunx require 'wb +Either form will dynamically load the WB database system from the +wb:vicinity (@file{../wb/}) specified in @file{Link.scm}. See +@file{scm/ANNOUNCE} for ftp sites where WB is available. +@end defun + +@noindent +The following functions comprise the low-level Scheme interface to +dynamic linking. See the file @file{Link.scm} in the SCM distribution +for an example of their use. + +@defun dyn:link filename +@var{filename} should be a string naming an @dfn{object} or +@dfn{archive} file, the result of C-compiling. The @code{dyn:link} +procedure links and loads @var{filename} into the current SCM session. +If successfull, @code{dyn:link} returns a @dfn{link-token} suitable for +passing as the second argument to @code{dyn:call}. If not successful, +@code{#f} is returned. +@end defun + +@defun dyn:call name link-token +@var{link-token} should be the value returned by a call to +@code{dyn:link}. @var{name} should be the name of C function of no +arguments defined in the file named @var{filename} which was succesfully +@code{dyn:link}ed in the current SCM session. The @code{dyn:call} +procedure calls the C function corresponding to @var{name}. If +successful, @code{dyn:call} returns @code{#t}; If not successful, +@code{#f} is returned. + +@code{dyn:call} is used to call the @dfn{init_@dots{}} function after +loading SCM object files. The init_@dots{} function then makes the +identifiers defined in the file accessible as Scheme procedures. +@end defun + +@defun dyn:main-call name link-token arg1 @dots{} +@var{link-token} should be the value returned by a call to +@code{dyn:link}. @var{name} should be the name of C function of 2 +arguments, @code{(int argc, char **argv)}, defined in the file named +@var{filename} which was succesfully @code{dyn:link}ed in the current +SCM session. The @code{dyn:main-call} procedure calls the C function +corresponding to @var{name} with @code{argv} style arguments, such as +are given to C @code{main} functions. If successful, +@code{dyn:main-call} returns the integer returned from the call to +@var{name}. + +@code{dyn:main-call} can be used to call a @code{main} procedure from +SCM. For example, I link in and @code{dyn:main-call} a large C program, +the low level routines of which callback (@pxref{Callbacks}) into SCM +(which emulates PCI hardware). +@end defun + +@defun dyn:unlink link-token +@var{link-token} should be the value returned by a call to +@code{dyn:link}. The @code{dyn:unlink} procedure removes the previously +loaded file from the current SCM session. If successful, +@code{dyn:unlink} returns @code{#t}; If not successful, @code{#f} is +returned. +@end defun + +@defun usr:lib lib +Returns the pathname of the C library named lib. For example: +@code{(usr:lib "m")} could return @code{"/usr/lib/libm.a"}, the path of +the C math library. +@end defun + +@node Dump, Numeric, Dynamic Linking, Packages +@section Dump + +@dfn{Dump}, (also known as @dfn{unexec}), saves the continuation of an +entire SCM session to an executable file, which can then be invoked as a +program. Dumped executables start very quickly, since no Scheme code +has to be loaded. + +@noindent +There are constraints on which sessions are savable using @code{dump} + +@itemize @bullet +@item +Saved continuations are invalid in subsequent invocations; they cause +segmentation faults and other unpleasant side effects. +@item +Although DLD (@pxref{Dynamic Linking}) can be used to load compiled +modules both before and after dumping, @samp{SUN_DL} ELF systems can +load compiled modules only after dumping. This can be worked around by +compiling in those features you wish to @code{dump}. +@item +Ports (other than @code{current-input-port}, @code{current-output-port}, +@code{current-error-port}), X windows, etc. are invalid in subsequent +invocations. + +This restriction could be removed; @xref{Improvements To Make}. +@item +@code{Dump} should only be called from a loading file when the call to +dump is the last expression in that file. +@item +@code{Dump} can be called from the command line. +@end itemize + +@defun dump newpath +@defunx dump newpath #f +@defunx dump newpath #t +@defunx dump newpath thunk +@itemize @bullet +@item +Calls @code{gc}. +@item +Creates an executable program named @var{newpath} which continues the +state of the current SCM session when invoked. The optional argument +@var{thunk}, if provided, should be a procedure of no arguments. This +procedure will be called in the restored executable. + +If the optional argument is missing or a boolean, SCM's standard command +line processing will be called in the restored executable. + +If the second argument to @code{dump} is @code{#t}, argument processing +will continue from the command line passed to the dumping session. If +the second argument is missing or @code{#f} then the command line +arguments of the restoring invocation will be processed. +@item +Resumes the top level Read-Eval-Print loop. This is done instead of +continuing normally to avoid creating a saved continuation in the dumped +executable. +@end itemize + +@code{dump} may set the values of @code{boot-tail}, @code{*argv*}, +@code{restart}, and @var{*interactive*}. @code{dump} returns an +unspecified value. +@end defun + +When a dumped executable is invoked, the variable @var{*interactive*} +(@pxref{System Interface}) has the value it possessed when @code{dump} +created it. Calling @code{dump} with a single argument sets +@var{*interactive*} to @code{#f}, which is the state it has at the +beginning of command line processing. + +The procedure @code{program-arguments} returns the command line +arguments for the curent invocation. More specifically, +@code{program-arguments} for the restored session are @emph{not} saved +from the dumping session. Command line processing is done on +the value of the identifier @code{*argv*}. + +The thunk @code{boot-tail} is called by SCM to process command line +arguments. @code{dump} sets @code{boot-tail} to the @var{thunk} it is +called with. + +The following example shows how to create @samp{rscm}, which is like +regular scm, but which loads faster and has the @samp{random} package +alreadly provided. + +@example +bash$ scm -rrandom +> (dump "rscm") +#<unspecified> +> (quit) +bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)" +00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 +37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 +70679 82148 08651 32823 06647 09384 46095 50582 23172 53594 +08128 48111 74502 84102 70193 85211 05559 64462 29489 +bash$ +@end example + +This task can also be accomplished using the @samp{-o} command line +option (@pxref{SCM Options}). + +@example +bash$ scm -rrandom -o rscm +> (quit) +bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)" +00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 +37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 +70679 82148 08651 32823 06647 09384 46095 50582 23172 53594 +08128 48111 74502 84102 70193 85211 05559 64462 29489 +bash$ +@end example + +@node Numeric, Arrays, Dump, Packages +@section Numeric + +@defvr Constant most-positive-fixnum +The immediate integer closest to positive infinity. +@xref{Configuration, , , slib, SLIB}. +@end defvr + +@defvr Constant most-negative-fixnum +The immediate integer closest to negative infinity. +@end defvr + +@noindent +These procedures augment the standard capabilities in @ref{Numerical +operations, , ,r4rs, Revised(4) Scheme}. + +@defun sinh z +@defunx cosh z +@defunx tanh z +Return the hyperbolic sine, cosine, and tangent of @var{z} +@end defun + +@defun asinh z +@defunx acosh z +@defunx atanh z +Return the inverse hyperbolic sine, cosine, and tangent of @var{z} +@end defun + +@defun $sqrt x +@defunx $abs x +@defunx $exp x +@defunx $log x +@defunx $sin x +@defunx $cos x +@defunx $tan x +@defunx $asin x +@defunx $acos x +@defunx $atan x + +@defunx $sinh x +@defunx $cosh x +@defunx $tanh x +@defunx $asinh x +@defunx $acosh x +@defunx $atanh x +Real-only versions of these popular functions. The argument @var{x} +must be a real number. It is an error if the value which should be +returned by a call to these procedures is @emph{not} real. +@end defun + +@defun $atan2 y x +Computes @code{(angle (make-rectangular x y))} for real numbers @var{y} +and @var{x}. +@end defun + +@defun $expt x1 x2 +Returns real number @var{x1} raised to the real power @var{x2}. It is +an error if the value which should be returned by a call to @code{$expt} +is not real. +@end defun + +@node Arrays, I/O-Extensions, Numeric, Packages +@section Arrays + +@menu +* Conventional Arrays:: +* Array Mapping:: +* Uniform Array:: +* Bit Vectors:: +@end menu + +@node Conventional Arrays, Array Mapping, Arrays, Arrays +@subsection Conventional Arrays + +@dfn{Arrays} read and write as a @code{#} followed by the @dfn{rank} +(number of dimensions) followed by what appear as lists (of lists) of +elements. The lists must be nested to the depth of the rank. For each +depth, all lists must be the same length. +@example +(make-array 'ho 3 3) @result{} +#2((ho ho ho) (ho ho ho) (ho ho ho)) +@end example + +Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension) +are equivalent to (and can't be distinguished from) vectors. +@example +(make-array 'ho 3) @result{} (ho ho ho) +@end example + +When constructing an array, @var{bound} is either an inclusive range of +indices expressed as a two element list, or an upper bound expressed +as a single integer. So +@example +(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2)) +@end example + +@defun array? obj +Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. +@end defun + +@defun make-array initial-value bound1 bound2 @dots{} +Creates and returns an array that has as many dimensions as there are +@var{bound}s and fills it with @var{initial-value}. +@end defun + +@defun array-ref array index1 index2 @dots{} +Returns the @var{index1}, @var{index2}, @dots{}'th element of +@var{array}. +@end defun + +@defun array-in-bounds? array index1 index2 @dots{} +Returns @code{#t} if its arguments would be acceptable to @var{array-ref}. +@end defun + +@defun array-set! array new-value index1 index2 @dots{} +Sets the @var{index1}, @var{index2}, @dots{}'th element of @var{array} +to @var{new-value}. The value returned by @code{array-set!} is +unspecified. +@end defun + +@defun make-shared-array array mapper bound1 bound2 @dots{} +@code{make-shared-array} can be used to create shared subarrays of other +arrays. The @var{mapper} is a function that translates coordinates in +the new array into coordinates in the old array. A @var{mapper} must be +linear, and its range must stay within the bounds of the old array, but +it can be otherwise arbitrary. A simple example: +@example +(define fred (make-array #f 8 8)) +(define freds-diagonal + (make-shared-array fred (lambda (i) (list i i)) 8)) +(array-set! freds-diagonal 'foo 3) +(array-ref fred 3 3) @result{} foo +(define freds-center + (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) +(array-ref freds-center 0 0) @result{} foo +@end example +@end defun + +@defun transpose-array array dim0 dim1 @dots{} +Returns an array sharing contents with @var{array}, but with dimensions +arranged in a different order. There must be one @var{dim} argument for +each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should +be integers between 0 and the rank of the array to be returned. Each +integer in that range must appear at least once in the argument list. + +The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions +in the array to be returned, their positions in the argument list to +dimensions of @var{array}. Several @var{dim}s may have the same value, +in which case the returned array will have smaller rank than +@var{array}. + +examples: +@example +(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) +(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) +(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} + #2((a 4) (b 5) (c 6)) +@end example +@end defun + +@defun enclose-array array dim0 dim1 @dots{} +@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than +the rank of @var{array}. @var{enclose-array} returns an array +resembling an array of shared arrays. The dimensions of each shared +array are the same as the @var{dim}th dimensions of the original array, +the dimensions of the outer array are the same as those of the original +array that did not match a @var{dim}. + +An enclosed array is not a general Scheme array. Its elements may not +be set using @code{array-set!}. Two references to the same element of +an enclosed array will be @code{equal?} but will not in general be +@code{eq?}. The value returned by @var{array-prototype} when given an +enclosed array is unspecified. + +examples: +@example +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} + #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))> + +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} + #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))> +@end example +@end defun + +@defun array-shape array +Returns a list of inclusive bounds of integers. +@example +(array-shape (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 4)) +@end example +@end defun + +@defun array-dimensions array +@code{Array-dimensions} is similar to @code{array-shape} but replaces +elements with a @code{0} minimum with one greater than the maximum. So: +@example +(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) +@end example +@end defun + +@defun array-rank obj +Returns the number of dimensions of @var{obj}. If @var{obj} is not an +array, @code{0} is returned. +@end defun + +@defun array->list array +Returns a list consisting of all the elements, in order, of @var{array}. +@end defun + +@defun array-copy! source destination +Copies every element from vector or array @var{source} to the +corresponding element of @var{destination}. @var{destination} must have +the same rank as @var{source}, and be at least as large in each +dimension. The order of copying is unspecified. +@end defun + +@defun serial-array-copy! source destination +Same as @code{array-copy!} but guaranteed to copy in row-major order. +@end defun + +@defun array-fill! array fill +Stores @var{fill} in every element of @var{array}. The value returned +is unspecified. +@end defun + +@defun array-equal? array0 array1 @dots{} +Returns @code{#t} iff all arguments are arrays with the same shape, the +same type, and have corresponding elements which are either +@code{equal?} or @code{array-equal?}. This function differs from +@code{equal?} in that a one dimensional shared array may be +@var{array-equal?} but not @var{equal?} to a vector or uniform vector. +@end defun + +@defun array-contents array +@defunx array-contents array strict +If @var{array} may be @dfn{unrolled} into a one dimensional shared array +without changing their order (last subscript changing fastest), then +@code{array-contents} returns that shared array, otherwise it returns +@code{#f}. All arrays made by @var{make-array} and +@var{make-uniform-array} may be unrolled, some arrays made by +@var{make-shared-array} may not be. + +If the optional argument @var{strict} is provided, a shared array will +be returned only if its elements are stored internally contiguous in +memory. +@end defun + +@node Array Mapping, Uniform Array, Conventional Arrays, Arrays +@subsection Array Mapping + +@defun array-map! array0 proc array1 @dots{} + +If @var{array1}, @dots{} are arrays, they must have the same number of +dimensions as @var{array0} and have a range for each index which +includes the range for the corresponding index in @var{array0}. +If they are scalars, that is, not arrays, vectors, or strings, then +they will be converted internally to arrays of the appropriate shape. +@var{proc} is applied to each tuple of elements of @var{array1} @dots{} +and the result is stored as the corresponding element in @var{array0}. +The value returned is unspecified. The order of application is +unspecified. + +@end defun + +@defun serial-array-map! array0 proc array1 @dots{} +Same as @var{array-map!}, but guaranteed to apply @var{proc} in +row-major order. +@end defun + +@defun array-for-each proc array0 @dots{} +@var{proc} is applied to each tuple of elements of @var{array0} @dots{} +in row-major order. The value returned is unspecified. +@end defun + +@defun array-index-map! array proc +applies @var{proc} to the indices of each element of @var{array} in +turn, storing the result in the corresponding element. The value +returned and the order of application are unspecified. + +One can implement @var{array-indexes} as +@example +(define (array-indexes array) + (let ((ra (apply make-array #f (array-shape array)))) + (array-index-map! ra (lambda x x)) + ra)) +@end example +Another example: +@example +(define (apl:index-generator n) + (let ((v (make-uniform-vector n 1))) + (array-index-map! v (lambda (i) i)) + v)) +@end example +@end defun + +@defun scalar->array scalar array prototype +Returns a uniform array of the same shape as @var{array}, having only +one shared element, which is @code{eqv?} to @var{scalar}. +If the optional argument @var{prototype} is supplied it will be used +as the prototype for the returned array. Otherwise the returned array +will be of the same type as @code{array} if that is possible, and +a conventional array if it is not. This function is used internally +by @code{array-map!} and friends to handle scalar arguments. +@end defun + +@node Uniform Array, Bit Vectors, Array Mapping, Arrays +@subsection Uniform Array + +@noindent +@dfn{Uniform Arrays} and vectors are arrays whose elements are all of +the same type. Uniform vectors occupy less storage than conventional +vectors. Uniform Array procedures also work on vectors, +uniform-vectors, bit-vectors, and strings. + +@noindent +@var{prototype} arguments in the following procedures are interpreted +according to the table: + +@example +prototype type display prefix + +#t boolean (bit-vector) #b +#\a char (string) #a +integer >0 unsigned integer #u +integer <0 signed integer #e +1.0 float (single precision) #s +1/3 double (double precision float) #i ++i complex (double precision) #c +() conventional vector # +@end example + +@noindent +Unshared uniform character 0-based arrays of rank 1 (dimension) +are equivalent to (and can't be distinguished from) strings. +@example +(make-uniform-array #\a 3) @result{} "$q2" +@end example + +@noindent +Unshared uniform boolean 0-based arrays of rank 1 (dimension) are +equivalent to (and can't be distinguished from) @ref{Bit Vectors, +bit-vectors}. +@example +(make-uniform-array #t 3) @result{} #*000 +@equiv{} +#b(#f #f #f) @result{} #*000 +@equiv{} +#1b(#f #f #f) @result{} #*000 +@end example + +@noindent +Other uniform vectors are written in a form similar to that of vectors, +except that a single character from the above table is put between +@code{#} and @code{(}. For example, @code{'#e(3 5 9)} returns a uniform +vector of signed integers. + +@defun uniform-vector-ref uve index +Returns the element at the @var{index} element in @var{uve}. +@end defun + +@defun uniform-vector-set! uve index new-value +Sets the element at the @var{index} element in @var{uve} to +@var{new-value}. The value returned by @code{uniform-vector-set!} is +unspecified. +@end defun + +@defun array? obj prototype +Returns @code{#t} if the @var{obj} is an array of type corresponding to +@var{prototype}, and @code{#f} if not. +@end defun + +@defun make-uniform-array prototype bound1 bound2 @dots{} +Creates and returns a uniform array of type corresponding to +@var{prototype} that has as many dimensions as there are @var{bound}s +and fills it with @var{prototype}. +@end defun + +@defun array-prototype array +Returns an object that would produce an array of the same type as +@var{array}, if used as the @var{prototype} for +@code{make-uniform-array}. +@end defun + +@defun list->uniform-array rank prot lst +@defunx list->uniform-vector prot lst +Returns a uniform array of the type indicated by prototype @var{prot} +with elements the same as those of @var{lst}. Elements must be of the +appropriate type, no coercions are done. +@end defun + +@defun uniform-vector-fill! uve fill +Stores @var{fill} in every element of @var{uve}. The value returned is +unspecified. +@end defun + +@defun uniform-vector-length uve +Returns the number of elements in @var{uve}. +@end defun + +@defun dimensions->uniform-array dims prototype fill +@defunx dimensions->uniform-array dims prototype +@defunx make-uniform-vector length prototype fill +@defunx make-uniform-vector length prototype +Creates and returns a uniform array or vector of type corresponding to +@var{prototype} with dimensions @var{dims} or length @var{length}. If +the @var{fill} argument is supplied, the returned array is filled with +this value. +@end defun + +@defun uniform-array-read! ura +@defunx uniform-array-read! ura port +@defunx uniform-vector-read! uve +@defunx uniform-vector-read! uve port +Attempts to read all elements of @var{ura}, in lexicographic order, as +binary objects from @var{port}. If an end of file is encountered during +uniform-array-read! the objects up to that point only are put into @var{ura} +(starting at the beginning) and the remainder of the array is +unchanged. + +@code{uniform-array-read!} returns the number of objects read. +@var{port} may be omitted, in which case it defaults to the value +returned by @code{(current-input-port)}. +@end defun + +@defun uniform-array-write ura +@defunx uniform-array-write ura port +@defunx uniform-vector-write uve +@defunx uniform-vector-write uve port +Writes all elements of @var{ura} as binary objects to @var{port}. The +number of of objects actually written is returned. @var{port} may be +omitted, in which case it defaults to the value returned by +@code{(current-output-port)}. +@end defun + +@node Bit Vectors, , Uniform Array, Arrays +@subsection Bit Vectors + +@noindent +Bit vectors can be written and read as a sequence of @code{0}s and +@code{1}s prefixed by @code{#*}. + +@example +#b(#f #f #f #t #f #t #f) @result{} #*0001010 +@end example + +@noindent +Some of these operations will eventually be generalized to other +uniform-arrays. + +@defun bit-count bool bv +Returns the number occurrences of @var{bool} in @var{bv}. +@end defun + +@defun bit-position bool bv k +Returns the minimum index of an occurrence of @var{bool} in @var{bv} +which is at least @var{k}. If no @var{bool} occurs within the specified +range @code{#f} is returned. +@end defun + +@defun bit-invert! bv +Modifies @var{bv} by replacing each element with its negation. +@end defun + +@defun bit-set*! bv uve bool +If uve is a bit-vector @var{bv} and uve must be of the same length. If +@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the +inversion of uve is AND'ed into @var{bv}. + +If uve is a unsigned integer vector all the elements of uve must be +between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv} +corresponding to the indexes in uve are set to @var{bool}. + +The return value is unspecified. +@end defun + +@defun bit-count* bv uve bool +Returns +@example +(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). +@end example +@var{bv} is not modified. +@end defun + + +@node I/O-Extensions, Posix Extensions, Arrays, Packages +@section I/O-Extensions + +@noindent +If @code{'i/o-extensions} is provided (by linking in @file{ioext.o}), +@ref{Line I/O, , , slib, SLIB}, and the following functions are defined: + +@defun isatty? port +Returns @code{#t} if @var{port} is input or output to a serial non-file device. +@end defun + +@defun stat <port-or-string> +Returns a vector of integers describing the argument. The argument +can be either a string or an open input port. If the argument is an +open port then the returned vector describes the file to which the +port is opened; If the argument is a string then the returned vector +describes the file named by that string. If there exists no file with +the name string, or if the file cannot be accessed @code{#f} is returned. +The elements of the returned vector are as follows: + + +@table @r +@item 0 st_dev +ID of device containing a directory entry for this file +@item 1 st_ino +Inode number +@item 2 st_mode +File type, attributes, and access control summary +@item 3 st_nlink +Number of links +@item 4 st_uid +User ID of file owner +@item 5 st_gid +Group ID of file group +@item 6 st_rdev +Device ID; this entry defined only for char or blk spec files +@item 7 st_size +File size (bytes) +@item 8 st_atime +Time of last access +@item 9 st_mtime +Last modification time +@item 10 st_ctime +Last file status change time +@end table +@end defun + +@defun getpid +Returns the process ID of the current process. +@end defun + +@defun file-position port +Returns the current position of the character in @var{port} which will +next be read or written. If @var{port} is not open to a file the result +is unspecified. +@end defun + +@defun file-set-position port integer +Sets the current position in @var{port} which will next be read or +written. If @var{port} is not open to a file the action of +@code{file-set-position} is unspecified. The result of +@code{file-set-position} is unspecified. +@end defun + +@defun reopen-file filename modes port +Closes port @var{port} and reopens it with @var{filename} and +@var{modes}. @code{reopen-file} returns @code{#t} if successful, +@code{#f} if not. +@end defun + +@defun duplicate-port port modes +Creates and returns a @dfn{duplicate} port from @var{port}. Duplicate +@emph{unbuffered} ports share one file position. @var{modes} are as for +@ref{Files and Ports, open-file}. +@end defun + +@defun redirect-port! from-port to-port +Closes @var{to-port} and makes @var{to-port} be a duplicate of +@var{from-port}. @code{redirect-port!} returns @var{to-port} if +successful, @code{#f} if not. If unsuccessful, @var{to-port} is not +closed. +@end defun + +@defun opendir dirname +Returns a @dfn{directory} object corresponding to the file system +directory named @var{dirname}. If unsuccessful, returns @code{#f}. +@end defun + +@defun readdir dir +Returns the string name of the next entry from the directory @var{dir}. +If there are no more entries in the directory, @code{readdir} returns a +@code{#f}. +@end defun + +@defun rewinddir dir +Reinitializes @var{dir} so that the next call to @code{readdir} with +@var{dir} will return the first entry in the directory again. +@end defun + +@defun closedir dir +Closes @var{dir} and returns @code{#t}. If @var{dir} is already +closed,, @code{closedir} returns a @code{#f}. +@end defun + +@defun mkdir path mode +The @code{mkdir} function creates a new, empty directory whose name is +@var{path}. The integer argument @var{mode} specifies the file +permissions for the new directory. @xref{The Mode Bits for Access +Permission, , , libc, Gnu C Library}, for more information about this. + +@code{mkdir} returns if successful, @code{#f} if not. +@end defun + +@defun rmdir path +The @code{rmdir} function deletes the directory @var{path}. The +directory must be empty before it can be removed. @code{rmdir} returns +if successful, @code{#f} if not. +@end defun + +@defun chdir filename +Changes the current directory to @var{filename}. If @var{filename} does not +exist or is not a directory, @code{#f} is returned. Otherwise, @code{#t} is +returned. +@end defun + +@defun getcwd +The function @code{getcwd} returns a string containing the absolute file +name representing the current working directory. If this string cannot +be obtained, @code{#f} is returned. +@end defun + +@defun rename-file oldfilename newfilename +Renames the file specified by @var{oldfilename} to @var{newfilename}. +If the renaming is successful, @code{#t} is returned. Otherwise, +@code{#f} is returned. +@end defun + +@defun chmod file mode +The function @code{chmod} sets the access permission bits for the file +named by @var{file} to @var{mode}. The @var{file} argument may be a +string containing the filename or a port open to the file. + +@code{chmod} returns if successful, @code{#f} if not. +@end defun + +@defun utime pathname acctime modtime +Sets the file times associated with the file named @var{pathname} to +have access time @var{acctime} and modification time @var{modtime}. +@code{utime} returns if successful, @code{#f} if not. +@end defun + +@defun umask mode +The function @code{umask} sets the file creation mask of the current +process to @var{mask}, and returns the previous value of the file +creation mask. +@end defun + +@defun fileno port +Returns the integer file descriptor associated with the port @var{port}. +If an error is detected, @code{#f} is returned. +@end defun + +@defun access pathname how +Returns @code{#t} if the file named by @var{pathname} can be accessed in +the way specified by the @var{how} argument. The @var{how} argument can +be the @code{logior} of the flags: + +@enumerate 0 +@item +File-exists? +@item +File-is-executable? +@item +File-is-writable? +@end enumerate +@enumerate 4 +@item +File-is-readable? +@end enumerate + +Or the @var{how} argument can be a string of 0 to 3 of the following +characters in any order. The test performed is the @code{and} of the +associated tests and @code{file-exists?}. + +@table @key +@item x +File-is-executable? +@item w +File-is-writable? +@item r +File-is-readable? +@end table +@end defun + +@defun execl command arg0 @dots{} +@defunx execlp command arg0 @dots{} +Transfers control to program @var{command} called with arguments +@var{arg0} @dots{}. For @code{execl}, @var{command} must be an exact +pathname of an executable file. @code{execlp} searches for +@var{command} in the list of directories specified by the environment +variable @var{PATH}. The convention is that @var{arg0} is the same name +as @var{command}. + +If successful, this procedure does not return. Otherwise an error +message is printed and the integer @code{errno} is returned. + +@defunx execv command arglist +@defunx execvp command arglist +Like @code{execl} and @code{execlp} except that the set of arguments to +@var{command} is @var{arglist}. +@end defun + +@defun putenv string +adds or removes definitions from the @dfn{environment}. If the +@var{string} is of the form @samp{NAME=VALUE}, the definition is added +to the environment. Otherwise, the @var{string} is interpreted as the +name of an environment variable, and any definition for this variable in +the environment is removed. + +Names of environment variables are case-sensitive and must not contain +the character @code{=}. System-defined environment variables are +invariably uppercase. + +@code{Putenv} is used to set up the environment before calls to +@code{execl}, @code{execlp}, @code{execv}, @code{execvp}, @code{system}, +or @code{open-pipe} (@pxref{I/O-Extensions, open-pipe}). + +To access environment variables, use @code{getenv} (@pxref{System +Interface, getenv, , slib, SLIB}). +@end defun + +@node Posix Extensions, Regular Expression Pattern Matching, I/O-Extensions, Packages +@section Posix Extensions + +@noindent +If @code{'posix} is provided (by linking in @file{posix.o}), the +following functions are defined: + +@defun open-pipe string modes +If the string @var{modes} contains an @key{r}, returns an input port +capable of delivering characters from the standard output of the system +command @var{string}. Otherwise, returns an output port capable of +receiving characters which become the standard input of the system +command @var{string}. If a pipe cannot be created @code{#f} is +returned. +@end defun + +@defun open-input-pipe string +Returns an input port capable of delivering characters from the +standard output of the system command @var{string}. If a pipe cannot be +created @code{#f} is returned. +@end defun + +@defun open-output-pipe string +Returns an output port capable of receiving characters which become +the standard input of the system command @var{string}. If a pipe cannot +be created @code{#f} is returned. +@end defun + +@defun close-port pipe +Closes the @var{pipe}, rendering it incapable of delivering or accepting +characters. This routine has no effect if the pipe has already been +closed. The value returned is unspecified. +@end defun + +@defun pipe +Returns @code{(cons @var{rd} @var{wd})} where @var{rd} and @var{wd} are +the read and write (port) ends of a @dfn{pipe} respectively. +@end defun + +@defun fork +Creates a copy of the process calling @code{fork}. Both processes +return from @code{fork}, but the calling (@dfn{parent}) process's +@code{fork} returns the @dfn{child} process's ID whereas the child +process's @code{fork} returns 0. +@end defun + +@noindent +For a discussion of @dfn{ID}s @xref{Process Persona, , , GNU C Library, +libc}. + +@defun getppid +Returns the process ID of the parent of the current process. +For a process's own ID @xref{I/O-Extensions, getpid}. +@end defun + +@defun getuid +Returns the real user ID of this process. +@end defun + +@defun getgid +Returns the real group ID of this process. +@end defun + +@defun getegid +Returns the effective group ID of this process. +@end defun + +@defun geteuid +Returns the effective user ID of this process. +@end defun + +@defun setuid id +Sets the real user ID of this process to @var{id}. +Returns @code{#t} if successful, @code{#f} if not. +@end defun + +@defun setgid id +Sets the real group ID of this process to @var{id}. +Returns @code{#t} if successful, @code{#f} if not. +@end defun + +@defun setegid id +Sets the effective group ID of this process to @var{id}. +Returns @code{#t} if successful, @code{#f} if not. +@end defun + +@defun seteuid id +Sets the effective user ID of this process to @var{id}. +Returns @code{#t} if successful, @code{#f} if not. +@end defun + +@defun kill pid sig +The @code{kill} function sends the signal @var{signum} to the process or +process group specified by @var{pid}. Besides the signals listed in +@ref{Standard Signals, , ,libc , GNU C Library}, @var{signum} can also +have a value of zero to check the validity of the @var{pid}. + +The @var{pid} specifies the process or process group to receive the +signal: + +@table @asis +@item > 0 +The process whose identifier is @var{pid}. + +@item 0 +All processes in the same process group as the sender. The +sender itself does not receive the signal. + +@item -1 +If the process is privileged, send the signal to all +processes except for some special system processes. +Otherwise, send the signal to all processes with the same +effective user ID. + +@item < -1 +The process group whose identifier is @code{(abs @var{pid})}. +@end table + +A process can send a signal to itself with @code{(kill (getpid) +@var{signum})}. If @code{kill} is used by a process to send a signal to +itself, and the signal is not blocked, then @code{kill} delivers at +least one signal (which might be some other pending unblocked signal +instead of the signal @var{signum}) to that process before it returns. + +The return value from @code{kill} is zero if the signal can be sent +successfully. Otherwise, no signal is sent, and a value of @code{-1} is +returned. If @var{pid} specifies sending a signal to several processes, +@code{kill} succeeds if it can send the signal to at least one of them. +There's no way you can tell which of the processes got the signal or +whether all of them did. +@end defun + +@defun waitpid pid options + +The @code{waitpid} function suspends execution of the current process +until a child as specified by the @var{pid} argument has exited, or until a +signal is deliverd whose action is to terminate the current process or +to call a signal handling function. If a child as requested by @var{pid} has +already exited by the time of the call (a so-called @dfn{zombie} +process), the function returns immediately. Any system resources used +by the child are freed. + +The value of @var{pid} can be one of: + +@table @asis +@item < -1 +which means to wait for any child process whose process group ID is +equal to the absolute value of + +@item -1 +which means to wait for any child process whose process group ID is +equal to the @code{(abs @var{pid})}. + +@item -1 +which means to wait for any child process; this is the same behaviour +which wait exhibits. + +@item 0 +which means to wait for any child process whose process group ID is +equal to that of the calling process. + +@item > 0 +which means to wait for the child whose process ID is equal to the value +of @var{pid}. +@end table + +The value of @var{options} is one of the following: + +@enumerate 0 +@item +Nothing special. + +@item +(@code{WNOHANG}) which means to return immediately if no child is there +to be waited for. + +@item +(@code{WUNTRACED}) which means to also return for children which are +stopped, and whose status has not been reported. + +@item +Which means both of the above. +@end enumerate + +The return value is normally the process ID of the child process whose +status is reported. If the @code{WNOHANG} option was specified and no +child process is waiting to be noticed, the value is zero. A value of +@code{#f} is returned in case of error and @code{errno} is set. For +information about the @code{errno} codes @xref{Process Completion, , , +GNU C Library, libc}. +@end defun + +@defun uname +You can use the @code{uname} procedure to find out some information +about the type of computer your program is running on. + +Returns a vector of strings. These strings are: + +@enumerate 0 +@item +The name of the operating system in use. +@item +The network name of this particular computer. +@item +The current release level of the operating system implementation. +@item +The current version level within the release of the operating system. +@item +Description of the type of hardware that is in use. + +Some examples are @samp{"i386-ANYTHING"}, @samp{"m68k-hp"}, +@samp{"sparc-sun"}, @samp{"m68k-sun"}, @samp{"m68k-sony"} and @samp{"mips-dec"}. +@end enumerate +@end defun + +@defun getpw name +@defunx getpw uid +@defunx getpw +Returns a vector of information for the entry for @code{NAME}, +@code{UID}, or the next entry if no argument is given. The +information is: + +@enumerate 0 +@item +The user's login name. +@item +The encrypted password string. +@item +The user ID number. +@item +The user's default group ID number. +@item +A string typically containing the user's real name, and +possibly other information such as a phone number. +@item +The user's home directory, initial working directory, or @code{#f}, in +which case the interpretation is system-dependent. +@item +The user's default shell, the initial program run when the user logs in, +or @code{#f}, indicating that the system default should be used. +@end enumerate +@end defun + +@defun setpwent #t +Rewinds the pw entry table back to the begining. + +@defunx setpwent #f +@defunx setpwent +Closes the pw table. +@end defun + + +@defun getgr name +@defunx getgr uid +@defunx getgr +Returns a vector of information for the entry for @code{NAME}, +@code{UID}, or the next entry if no argument is given. The +information is: + +@enumerate 0 +@item +The name of the group. +@item +The encrypted password string. +@item +The group ID number. +@item +A list of (string) names of users in the group. +@end enumerate +@end defun + +@defun setgrent #t +Rewinds the group entry table back to the begining. + +@defunx setgrent #f +@defunx setgrent +Closes the group table. +@end defun + +@defun getgroups +Returns a vector of all the supplementary group IDs of the process. +@end defun + + +@defun link oldname newname +The @code{link} function makes a new link to the existing file named by +@var{oldname}, under the new name @var{newname}. + +@code{link} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun chown filename owner group +The @code{chown} function changes the owner of the file @var{filename} +to @var{owner}, and its group owner to @var{group}. + +@code{chown} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun ttyname port +If port @var{port} is associated with a terminal device, returns a +string containing the file name of termainal device; otherwise +@code{#f}. +@end defun + +@section Unix Extensions + +@noindent +If @code{'unix} is provided (by linking in @file{unix.o}), the following +functions are defined: + +@noindent +These @dfn{priveledged} and symbolic link functions are not in Posix: + +@defun symlink oldname newname +The @code{symlink} function makes a symbolic link to @var{oldname} named +@var{newname}. + +@code{symlink} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun readlink filename +Returns the value of the symbolic link @var{filename} or @code{#f} for +failure. +@end defun + +@defun lstat filename +The @code{lstat} function is like @code{stat}, except that it does not +follow symbolic links. If @var{filename} is the name of a symbolic +link, @code{lstat} returns information about the link itself; otherwise, +@code{lstat} works like @code{stat}. @xref{I/O-Extensions}. +@end defun + +@defun nice increment +Increment the priority of the current process by @var{increment}. +@code{chown} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun acct filename +When called with the name of an exisitng file as argument, accounting is +turned on, records for each terminating pro-cess are appended to +@var{filename} as it terminates. An argument of @code{#f} causes +accounting to be turned off. + +@code{acct} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun mknod filename mode dev +The @code{mknod} function makes a special file with name @var{filename} +and modes @var{mode} for device number @var{dev}. + +@code{mknod} returns a value of @code{#t} if it is successful and +@code{#f} on failure. +@end defun + +@defun sync +@code{sync} first commits inodes to buffers, and then buffers to disk. +sync() only schedules the writes, so it may return before the actual +writing is done. The value returned is unspecified. +@end defun + +@node Regular Expression Pattern Matching, Line Editing, Posix Extensions, Packages +@section Regular Expression Pattern Matching + +These functions are defined in @file{rgx.c} using a POSIX or GNU +@dfn{regex} library. If your computer does not support regex, a package +is available via ftp from +@file{prep.ai.mit.edu:/pub/gnu/regex-0.12.tar.gz}. For a description of +regular expressions, @xref{syntax, , , regex, "regex" regular expression +matching library}. + +@defun regcomp @var{pattern} [@var{flags}] +Compile a @dfn{regular expression}. Return a compiled regular +expression, or an integer error code suitable as an argument to +@code{regerror}. + +@var{flags} in @code{regcomp} is a string of option letters used to +control the compilation of the regular expression. The letters may +consist of: + +@table @samp +@item n +newlines won't be matched by @code{.} or hat lists; ( @code{[^...]} ) +@item i +ignore case. +@exdent only when compiled with @var{_GNU_SOURCE}: +@item 0 +allows dot to match a null character. +@item f +enable GNU fastmaps. +@end table +@end defun + +@defun regerror @var{errno} +Returns a string describing the integer @var{errno} returned when +@code{regcomp} fails. +@end defun + +@defun regexec @var{re} @var{string} +Returns @code{#f} or a vector of integers. These integers are in +doublets. The first of each doublet is the index of @var{string} of +the start of the matching expression or sub-expression (delimited by +parentheses in the pattern). The last of each doublet is index of +@var{string} of the end of that expression. @code{#f} is returned if +the string does not match. +@end defun + +@defun regmatch? @var{re} @var{string} +Returns @code{#t} if the @var{pattern} such that @var{regexp} = (regcomp +@var{pattern}) matches @var{string} as a POSIX extended regular +expressions. Returns @code{#f} otherwise. +@end defun + +@defun regsearch @var{re} @var{string} [@var{start} [@var{len}]] +@defunx regsearchv @var{re} @var{string} [@var{start} [@var{len}]] +@defunx regmatch @var{re} @var{string} [@var{start} [@var{len}]] +@defunx regmatchv @var{re} @var{string} [@var{start} [@var{len}]] +@code{Regsearch} searches for the pattern within the string. + +@code{Regmatch} anchors the pattern and begins matching it against +string. + +@code{Regsearch} returns the character position where @var{re} starts, +or @code{#f} if not found. + +@code{Regmatch} returns the number of characters matched, @code{#f} if +not matched. + +@code{Regsearchv} and @code{regmatchv} return the match vector is +returned if @var{re} is found, @code{#f} otherwise. + +@table @var +@item re +may be either: +@enumerate +@item +a compiled regular expression returned by @code{regcomp}; +@item +a string representing a regular expression; +@item +a list of a string and a set of option letters. +@end enumerate +@item string +The string to be operated upon. +@item start +The character position at which to begin the search or match. If absent, +the default is zero. + +@exdent @emph{Compiled _GNU_SOURCE and using GNU libregex only:} + +When searching, if @var{start} is negative, the absolute value of +@var{start} will be used as the start location and reverse searching +will be performed. + +@item len +The search is allowed to examine only the first @var{len} characters of +@var{string}. If absent, the entire string may be examined. +@end table +@end defun + +@defun string-split @var{re} @var{string} +@defunx string-splitv @var{re} @var{string} +@code{String-split} splits a string into substrings that are separated +by @var{re}, returning a vector of substrings. + +@code{String-splitv} returns a vector of string positions that indicate +where the substrings are located. +@end defun + +@defun string-edit @var{re} @var{edit-spec} @var{string} [@var{count}] +Returns the edited string. + +@table @var +@item edit-spec +Is a string used to replace occurances of @var{re}. Backquoted integers +in the range of 1-9 may be used to insert subexpressions in @var{re}, as +in @code{sed}. +@item count +The number of substitutions for @code{string-edit} to perform. If +@code{#t}, all occurances of @var{re} will be replaced. The default is +to perform one substitution. +@end table +@end defun + +@node Line Editing, Curses, Regular Expression Pattern Matching, Packages +@section Line Editing + +@noindent +These procedures provide input line editing and recall. + +@noindent +These functions are defined in @file{edline.c} and @file{Iedline.scm} +using the @dfn{editline} or GNU @dfn{readline} (@pxref{Top, , Overview +,readline ,GNU Readline Library}) libraries available from: + +@itemize @bullet +@item +@ifset html +<A HREF="ftp://ftp.sys.toronto.edu/pub/rc/editline.shar"> +@end ifset +@code{ftp.sys.toronto.edu:/pub/rc/editline.shar} +@ifset html +</A> +@end ifset +@item +@ifset html +<A HREF="ftp://prep.ai.mit.edu/pub/gnu/readline-2.0.tar.gz"> +@end ifset +@code{prep.ai.mit.edu:/pub/gnu/readline-2.0.tar.gz} +@ifset html +</A> +@end ifset +@end itemize + +@noindent +When @file{Iedline.scm} is loaded, if the current input port is the +default input port and the environment variable @var{EMACS} is not +defined, line-editing mode will be entered. + +@defun default-input-port +Returns the initial @code{current-input-port} SCM was invoked with +(stdin). +@end defun + +@defun default-output-port +Returns the initial @code{current-output-port} SCM was invoked with +(stdout). +@end defun + +@defun make-edited-line-port +Returns an input/output port that allows command line editing and +retrieval of history. +@end defun + +@defun line-editing +Returns the current edited line port or @code{#f}. + +@defunx line-editing bool +If @var{bool} is false, exits line-editing mode and returns the previous +value of @code{(line-editing)}. If @var{bool} is true, sets the current +input and output ports to an edited line port and returns the previous +value of @code{(line-editing)}. +@end defun + +@node Curses, Sockets, Line Editing, Packages +@section Curses + +@noindent +These functions are defined in @file{crs.c} using the @dfn{curses} +library. Unless otherwise noted these routines return @code{#t} for +successful completion and @code{#f} for failure. + +@defun initscr +Returns a port for a full screen window. This routine must be called to +initialize curses. +@end defun + +@defun endwin +A program should call @code{endwin} before exiting or escaping from +curses mode temporarily, to do a system call, for example. This routine +will restore termio modes, move the cursor to the lower left corner of +the screen and reset the terminal into the proper non-visual mode. To +resume after a temporary escape, call @ref{Window Manipulation, +refresh}. +@end defun + +@menu +* Output Options Setting:: +* Terminal Mode Setting:: +* Window Manipulation:: +* Output:: +* Input:: +* Curses Miscellany:: +@end menu + +@node Output Options Setting, Terminal Mode Setting, Curses, Curses +@subsection Output Options Setting + +@noindent +These routines set options within curses that deal with output. All +options are initially @code{#f}, unless otherwise stated. It is not +necessary to turn these options off before calling @code{endwin}. + +@defun clearok win bf +If enabled (@var{bf} is @code{#t}), the next call to @code{force-output} +or @code{refresh} with @var{win} will clear the screen completely and +redraw the entire screen from scratch. This is useful when the contents +of the screen are uncertain, or in some cases for a more pleasing visual +effect. +@end defun + +@defun idlok win bf +If enabled (@var{bf} is @code{#t}), curses will consider using the +hardware ``insert/delete-line'' feature of terminals so equipped. If +disabled (@var{bf} is @code{#f}), curses will very seldom use this +feature. The ``insert/delete-character'' feature is always considered. +This option should be enabled only if your application needs +``insert/delete-line'', for example, for a screen editor. It is +disabled by default because + +``insert/delete-line'' tends to be visually annoying when used in +applications where it is not really needed. If ``insert/delete-line'' +cannot be used, curses will redraw the changed portions of all lines. +@end defun + +@defun leaveok win bf +Normally, the hardware cursor is left at the location of the window +cursor being refreshed. This option allows the cursor to be left +wherever the update happens to leave it. It is useful for +applications where the cursor is not used, since it reduces the need +for cursor motions. If possible, the cursor is made invisible when +this option is enabled. +@end defun + +@defun scrollok win bf +This option controls what happens when the cursor of window @var{win} is +moved off the edge of the window or scrolling region, either from a +newline on the bottom line, or typing the last character of the last +line. If disabled (@var{bf} is @code{#f}), the cursor is left on the +bottom line at the location where the offending character was entered. +If enabled (@var{bf} is @code{#t}), @code{force-output} is called on the +window @var{win}, and then the physical terminal and window @var{win} +are scrolled up one line. + +@emph{Note:} in order to get the physical scrolling effect on the +terminal, it is also necessary to call @code{idlok}. +@end defun + +@defun nodelay win bf +This option causes wgetch to be a non-blocking call. If no input is +ready, wgetch will return an eof-object. If disabled, wgetch will hang +until a key is pressed. +@end defun + +@node Terminal Mode Setting, Window Manipulation, Output Options Setting, Curses +@subsection Terminal Mode Setting + +@noindent +These routines set options within curses that deal with input. The +options involve using ioctl(2) and therefore interact with curses +routines. It is not necessary to turn these options off before +calling @code{endwin}. The routines in this section all return an +unspecified value. + +@defun cbreak +@defunx nocbreak +These two routines put the terminal into and out of @code{CBREAK} mode, +respectively. In @code{CBREAK} mode, characters typed by the user are +immediately available to the program and erase/kill character +processing is not performed. When in @code{NOCBREAK} mode, the tty driver +will buffer characters typed until a @key{LFD} or @key{RET} is typed. +Interrupt and flowcontrol characters are unaffected by this mode. +Initially the terminal may or may not be in @code{CBREAK} mode, as it is +inherited, therefore, a program should call @code{cbreak} or @code{nocbreak} +explicitly. Most interactive programs using curses will set @code{CBREAK} +mode. + +@emph{Note:} @code{cbreak} overrides @code{raw}. For a discussion of +how these routines interact with @code{echo} and @code{noecho} +@xref{Input, read-char}. +@end defun + +@defun raw +@defunx noraw +The terminal is placed into or out of @code{RAW} mode. @code{RAW} mode +is similar to @code{CBREAK} mode, in that characters typed are +immediately passed through to the user program. The differences are +that in @code{RAW} mode, the interrupt, quit, suspend, and flow control +characters are passed through uninterpreted, instead of generating a +signal. @code{RAW} mode also causes 8-bit input and output. The +behavior of the @code{BREAK} key depends on other bits in the terminal +driver that are not set by curses. +@end defun + +@defun echo +@defunx noecho +These routines control whether characters typed by the user are echoed +by @code{read-char} as they are typed. Echoing by the tty driver is +always disabled, but initially @code{read-char} is in @code{ECHO} mode, +so characters typed are echoed. Authors of most interactive programs +prefer to do their own echoing in a controlled area of the screen, or +not to echo at all, so they disable echoing by calling @code{noecho}. +For a discussion of how these routines interact with @code{echo} and +@code{noecho} @xref{Input, read-char}. +@end defun + +@defun nl +@defunx nonl +These routines control whether @key{LFD} is translated into @key{RET} +and @code{LFD} on output, and whether @key{RET} is translated into +@key{LFD} on input. Initially, the translations do occur. By disabling +these translations using @code{nonl}, curses is able to make better use +of the linefeed capability, resulting in faster cursor motion. +@end defun + +@defun resetty +@defunx savetty +These routines save and restore the state of the terminal modes. +@code{savetty} saves the current state of the terminal in a buffer and +@code{resetty} restores the state to what it was at the last call to +@code{savetty}. +@end defun + +@node Window Manipulation, Output, Terminal Mode Setting, Curses +@subsection Window Manipulation + +@defun newwin nlines ncols begy begx +Create and return a new window with the given number of lines (or rows), +@var{nlines}, and columns, @var{ncols}. The upper left corner of the +window is at line @var{begy}, column @var{begx}. If either @var{nlines} +or @var{ncols} is 0, they will be set to the value of +@code{LINES}-@var{begy} and @code{COLS}-@var{begx}. A new full-screen +window is created by calling @code{newwin(0,0,0,0)}. +@end defun + +@defun subwin orig nlines ncols begy begx +Create and return a pointer to a new window with the given number of +lines (or rows), @var{nlines}, and columns, @var{ncols}. The window is +at position (@var{begy}, @var{begx}) on the screen. This position is +relative to the screen, and not to the window @var{orig}. The window is +made in the middle of the window @var{orig}, so that changes made to one +window will affect both windows. When using this routine, often it will +be necessary to call @code{touchwin} or @code{touchline} on @var{orig} +before calling @code{force-output}. +@end defun + +@defun close-port win +Deletes the window @var{win}, freeing up all memory associated with it. +In the case of sub-windows, they should be deleted before the main +window @var{win}. +@end defun + +@defun refresh +@defunx force-output win +These routines are called to write output to the terminal, as most other +routines merely manipulate data structures. @code{force-output} copies +the window @var{win} to the physical terminal screen, taking into +account what is already there in order to minimize the amount of +information that's sent to the terminal (called optimization). Unless +@code{leaveok} has been enabled, the physical cursor of the terminal is +left at the location of window @var{win}'s cursor. With @code{refresh}, +the number of characters output to the terminal is returned. +@end defun + +@defun mvwin win y x +Move the window @var{win} so that the upper left corner will be at position +(@var{y}, @var{x}). If the move would cause the window @var{win} to be off the +screen, it is an error and the window @var{win} is not moved. +@end defun + +@defun overlay srcwin dstwin +@defunx overwrite srcwin dstwin + +These routines overlay @var{srcwin} on top of @var{dstwin}; that is, all +text in @var{srcwin} is copied into @var{dstwin}. @var{srcwin} and +@var{dstwin} need not be the same size; only text where the two windows +overlap is copied. The difference is that @code{overlay} is +non-destructive (blanks are not copied), while @code{overwrite} is +destructive. +@end defun + +@defun touchwin win +@defunx touchline win start count +Throw away all optimization information about which parts of the window +@var{win} have been touched, by pretending that the entire window +@var{win} has been drawn on. This is sometimes necessary when using +overlapping windows, since a change to one window will affect the other +window, but the records of which lines have been changed in the other +window will not reflect the change. @code{touchline} only pretends that +@var{count} lines have been changed, beginning with line @var{start}. +@end defun + +@defun wmove win y x +The cursor associated with the window @var{win} is moved to line (row) @var{y}, +column @var{x}. This does not move the physical cursor of the terminal +until @code{refresh} (or @code{force-output}) is called. The position +specified is relative to the upper left corner of the window @var{win}, +which is (0, 0). +@end defun + +@node Output, Input, Window Manipulation, Curses +@subsection Output + +@noindent +These routines are used to @dfn{draw} text on windows + +@defun display ch win +@defunx display str win +@defunx wadd win ch +@defunx wadd win str +The character @var{ch} or characters in @var{str} are put into the +window @var{win} at the current cursor position of the window and the +position of @var{win}'s cursor is advanced. At the right margin, an +automatic newline is performed. At the bottom of the scrolling region, +if scrollok is enabled, the scrolling region will be scrolled up one +line. + +If @var{ch} is a @key{TAB}, @key{LFD}, or backspace, the cursor will be +moved appropriately within the window @var{win}. A @key{LFD} also does a +@code{wclrtoeol} before moving. @key{TAB} characters are considered to +be at every eighth column. If @var{ch} is another control character, it +will be drawn in the @kbd{C-x} notation. (Calling @code{winch} after +adding a control character will not return the control character, but +instead will return the representation of the control character.) + +Video attributes can be combined with a character by or-ing them into +the parameter. This will result in these attributes also being set. +The intent here is that text, including attributes, can be copied from +one place to another using inch and display. See @code{standout}, +below. + +@emph{Note:} For @code{wadd} @var{ch} can be an integer and will insert +the character of the corresponding value. +@end defun + +@defun werase win +This routine copies blanks to every position in the window @var{win}. +@end defun + +@defun wclear win +This routine is like @code{werase}, but it also calls @ref{Output +Options Setting, clearok}, arranging that the screen will be cleared +completely on the next call to @code{refresh} or @code{force-output} for +window @var{win}, and repainted from scratch. +@end defun + +@defun wclrtobot win +All lines below the cursor in window @var{win} are erased. Also, the +current line to the right of the cursor, inclusive, is erased. +@end defun + +@defun wclrtoeol win +The current line to the right of the cursor, inclusive, is erased. +@end defun + +@defun wdelch win +The character under the cursor in the window @var{win} is deleted. All +characters to the right on the same line are moved to the left one +position and the last character on the line is filled with a blank. The +cursor position does not change. This does not imply use of the +hardware ``delete-character'' feature. +@end defun + +@defun wdeleteln win +The line under the cursor in the window @var{win} is deleted. All lines +below the current line are moved up one line. The bottom line @var{win} +is cleared. The cursor position does not change. This does not imply +use of the hardware ``deleteline'' feature. +@end defun + +@defun winsch win ch +The character @var{ch} is inserted before the character under the +cursor. All characters to the right are moved one @key{SPC} to the +right, possibly losing the rightmost character of the line. The cursor +position does not change . This does not imply use of the hardware +``insertcharacter'' feature. +@end defun + +@defun winsertln win +A blank line is inserted above the current line and the bottom line is +lost. This does not imply use of the hardware ``insert-line'' feature. +@end defun + +@defun scroll win +The window @var{win} is scrolled up one line. This involves moving the +lines in @var{win}'s data structure. As an optimization, if @var{win} +is stdscr and the scrolling region is the entire window, the physical +screen will be scrolled at the same time. +@end defun + +@node Input, Curses Miscellany, Output, Curses +@subsection Input + +@defun read-char win +A character is read from the terminal associated with the window +@var{win}. Depending on the setting of @code{cbreak}, this will be +after one character (@code{CBREAK} mode), or after the first newline +(@code{NOCBREAK} mode). Unless @code{noecho} has been set, the +character will also be echoed into @var{win}. + +When using @code{read-char}, do not set both @code{NOCBREAK} mode +(@code{nocbreak}) and @code{ECHO} mode (@code{echo}) at the same time. +Depending on the state of the terminal driver when each character is +typed, the program may produce undesirable results. +@end defun + +@defun winch win +The character, of type chtype, at the current position in window +@var{win} is returned. If any attributes are set for that position, +their values will be OR'ed into the value returned. +@end defun + +@defun getyx win +A list of the y and x coordinates of the cursor position of the window +@var{win} is returned +@end defun + +@node Curses Miscellany, , Input, Curses +@subsection Curses Miscellany + +@defun wstandout win +@defunx wstandend win + +These functions set the current attributes of the window @var{win}. The +current attributes of @var{win} are applied to all characters that are +written into it. Attributes are a property of the character, and move +with the character through any scrolling and insert/delete +line/character operations. To the extent possible on the particular +terminal, they will be displayed as the graphic rendition of characters +put on the screen. + +@code{wstandout} sets the current attributes of the window @var{win} to +be visibly different from other text. @code{wstandend} turns off the +attributes. +@end defun + +@defun box win vertch horch +A box is drawn around the edge of the window @var{win}. @var{vertch} +and @var{horch} are the characters the box is to be drawn with. If +@var{vertch} and @var{horch} are 0, then appropriate default characters, +@code{ACS_VLINE} and @code{ACS_HLINE}, will be used. + +@emph{Note:} @var{vertch} and @var{horch} can be an integers and will +insert the character (with attributes) of the corresponding values. +@end defun + +@defun unctrl c +This macro expands to a character string which is a printable +representation of the character @var{c}. Control characters are +displayed in the @kbd{C-x} notation. Printing characters are displayed +as is. +@end defun + +@node Sockets, , Curses, Packages +@section Sockets + +@noindent +These procedures (defined in @file{socket.c}) provide a Scheme interface +to most of the C @dfn{socket} library. For more information on sockets, +@xref{Sockets, , , libc, The GNU C Library Reference Manual}. + +@menu +* Host Data:: +* Internet Addresses and Socket Names:: +* Socket:: +@end menu + +@node Host Data, Internet Addresses and Socket Names, Sockets, Sockets +@subsection Host Data, Network, Protocol, and Service Inquiries + +@defvr Constant af_inet +@defvrx Constant af_unix +Integer family codes for Internet and Unix sockets, respectively. +@end defvr + +@defun gethost host-spec +@defunx gethost +Returns a vector of information for the entry for @code{HOST-SPEC} or the +next entry if @code{HOST-SPEC} isn't given. The information is: + +@enumerate 0 +@item +host name string +@item +list of host aliases strings +@item +integer address type (@code{AF_INET}) +@item +integer size of address entries (in bytes) +@item +list of integer addresses +@end enumerate +@end defun + +@defun sethostent stay-open +@defunx sethostent +Rewinds the host entry table back to the begining if given an argument. +If the argument @var{stay-open} is @code{#f} queries will be be done +using @code{UDP} datagrams. Otherwise, a connected @code{TCP} socket +will be used. When called without an argument, the host table is +closed. +@end defun + +@defun getnet name-or-number +@defunx getnet +Returns a vector of information for the entry for @var{name-or-number} or +the next entry if an argument isn't given. The information is: + +@enumerate 0 +@item +official network name string +@item +list of network aliases strings +@item +integer network address type (@code{AF_INET}) +@item +integer network number +@end enumerate +@end defun + +@defun setnetent stay-open +@defunx setnetent +Rewinds the network entry table back to the begining if given an +argument. If the argument @var{stay-open} is @code{#f} the table will be closed +between calls to getnet. Otherwise, the table stays open. When +called without an argument, the network table is closed. +@end defun + +@defun getproto name-or-number +@defunx getproto +Returns a vector of information for the entry for @var{name-or-number} or +the next entry if an argument isn't given. The information is: + +@enumerate +@item +official protocol name string +@item +list of protocol aliases strings +@item +integer protocol number +@end enumerate +@end defun + +@defun setprotoent stay-open +@defunx setprotoent +Rewinds the protocol entry table back to the begining if given an +argument. If the argument @var{stay-open} is @code{#f} the table will be closed +between calls to getproto. Otherwise, the table stays open. When +called without an argument, the protocol table is closed. +@end defun + +@defun getserv name-or-port-number protocol +@defunx getserv +Returns a vector of information for the entry for @var{name-or-port-number} +and @var{protocol} or the next entry if arguments aren't given. The +information is: + +@enumerate 0 +@item +official service name string +@item +list of service aliases strings +@item +integer port number +@item +protocol +@end enumerate +@end defun + +@defun setservent stay-open +@defunx setservent +Rewinds the service entry table back to the begining if given an +argument. If the argument @var{stay-open} is @code{#f} the table will be closed +between calls to getserv. Otherwise, the table stays open. When +called without an argument, the service table is closed. +@end defun + +@node Internet Addresses and Socket Names, Socket, Host Data, Sockets +@subsection Internet Addresses and Socket Names + +@defun inet:string->address string +Returns the host address number (integer) for host @var{string} or +@code{#f} if not found. +@end defun + +@defun inet:address->string address +Converts an internet (integer) address to a string in numbers and dots +notation. This is an inverse function to inet:address. +@end defun + +@defun inet:network address +Returns the network number (integer) specified from @var{address} or +@code{#f} if not found. +@end defun + +@defun inet:local-network-address address +Returns the integer for the address of @var{address} within its local +network or @code{#f} if not found. +@end defun + +@defun inet:make-address network local-address +Returns the Internet address of @var{local-address} in @var{network}. +@end defun + +@noindent +The type @dfn{socket-name} is used for inquiries about open sockets in +the following procedures: + +@defun getsockname socket +Returns the socket-name of @var{socket}. Returns @code{#f} if +unsuccessful or @var{socket} is closed. +@end defun + +@defun getpeername socket +Returns the socket-name of the socket connected to @var{socket}. +Returns @code{#f} if unsuccessful or @var{socket} is closed. +@end defun + +@defun socket-name:family socket-name +Returns the integer code for the family of @var{socket-name}. +@end defun + +@defun socket-name:port-number socket-name +Returns the integer port number of @var{socket-name}. +@end defun + +@defun socket-name:address socket-name +Returns the integer Internet address for @var{socket-name}. +@end defun + + +@node Socket, , Internet Addresses and Socket Names, Sockets +@subsection Socket + +@noindent +When a port is returned from one of these calls it is unbuffered. +This allows both reading and writing to the same port to work. If you +want buffered ports you can (assuming sock-port is a socket i/o port): +@example +(require 'i/o-extensions) +(define i-port (duplicate-port sock-port "r")) +(define o-port (duplicate-port sock-port "w")) +@end example + +@defun make-stream-socket family +@defunx make-stream-socket family protocol + +Returns a @code{SOCK_STREAM} socket of type @var{family} using +@var{protocol}. If @var{family} has the value @code{AF_INET}, +@code{SO_REUSEADDR} will be set. The integer argument @var{protocol} +corresponds to the integer protocol numbers returned (as vector +elements) from @code{(getproto)}. If the @var{protocol} argument is not +supplied, the default (0) for the specified @var{family} is used. SCM +sockets look like ports opened for neither reading nor writing. +@end defun + +@defun make-stream-socketpair family +@defunx make-stream-socketpair family protocol + +Returns a pair (cons) of connected @code{SOCK_STREAM} (socket) ports of +type @var{family} using @var{protocol}. Many systems support only +socketpairs of the @code{af-unix} @var{family}. The integer argument +@var{protocol} corresponds to the integer protocol numbers returned (as +vector elements) from (getproto). If the @var{protocol} argument is +not supplied, the default (0) for the specified @var{family} is used. +@end defun + +@defun socket:shutdown socket how +Makes @var{socket} no longer respond to some or all operations depending on +the integer argument @var{how}: + +@enumerate 0 +@item +Further input is disallowed. +@item +Further output is disallowed. +@item +Further input or output is disallowed. +@end enumerate + +@code{Socket:shutdown} returns @var{socket} if successful, @code{#f} if +not. +@end defun + +@defun socket:connect inet-socket host-number port-number +@defunx socket:connect unix-socket pathname +Returns @var{socket} (changed to a read/write port) connected to the +Internet socket on host @var{host-number}, port @var{port-number} or +the Unix socket specified by @var{pathname}. Returns @code{#f} if not +successful. +@end defun + +@defun socket:bind inet-socket port-number +@defunx socket:bind unix-socket pathname +Returns @var{inet-socket} bound to the integer @var{port-number} or the +@var{unix-socket} bound to new socket in the file system at location +@var{pathname}. Returns @code{#f} if not successful. Binding a +@var{unix-socket} creates a socket in the file system that must be +deleted by the caller when it is no longer needed (using +@code{delete-file}). +@end defun + +@defun socket:listen socket backlog +The bound (@pxref{Socket, bind}) @var{socket} is readied to +accept connections. The positive integer @var{backlog} specifies how +many pending connections will be allowed before further connection +requests are refused. Returns @var{socket} (changed to a read-only +port) if successful, @code{#f} if not. +@end defun + +@defun char-ready? listen-socket +The input port returned by a successful call to @code{socket:listen} can +be polled for connections by @code{char-ready?} (@pxref{Files and Ports, +char-ready?}). This avoids blocking on connections by +@code{socket:accept}. +@end defun + +@defun socket:accept socket +Accepts a connection on a bound, listening @var{socket}. Returns an +input/output port for the connection. +@end defun + +@noindent +The following example is not too complicated, yet shows the use of +sockets for multiple connections without input blocking. + +@example +;;;; Scheme chat server + +;;; This program implements a simple `chat' server which accepts +;;; connections from multiple clients, and sends to all clients any +;;; characters received from any client. + +;;; To connect to chat `telnet localhost 8001' + +(require 'socket) +(require 'i/o-extensions) + +(let ((listener-socket (socket:bind (make-stream-socket af_inet) 8001)) + (connections '())) + (socket:listen listener-socket 5) + (do () (#f) + (cond ((char-ready? listener-socket) + (let ((con (socket:accept listener-socket))) + (display "accepting connection from ") + (display (getpeername con)) + (newline) + (set! connections (cons con connections)) + (display "connected" con) + (newline con)))) + (set! connections + (let next ((con-list connections)) + (cond ((null? con-list) '()) + (else + (let ((con (car con-list))) + (cond ((char-ready? con) + (let ((c (read-char con))) + (cond ((eof-object? c) + (display "closing connection from ") + (display (getpeername con)) + (newline) + (close-port con) + (next (cdr con-list))) + (else + (for-each (lambda (con) + (file-set-position con 0) + (write-char c con) + (file-set-position con 0)) + connections) + (cons con (next (cdr con-list))))))) + (else (cons con (next (cdr con-list)))))))))))) +@end example + +@noindent +You can use @samp{telnet localhost 8001} to connect to the chat server, +or you can use a client written in scheme: + +@example +;;;; Scheme chat client + +;;; this program connects to socket 8001. It then sends all +;;; characters from current-input-port to the socket and sends all +;;; characters from the socket to current-output-port. + +(require 'socket) +(require 'i/o-extensions) + +(define con (make-stream-socket af_inet)) +(set! con (socket:connect con (inet:string->address "localhost") 8001)) + +(do ((cs #f (and (char-ready? con) (read-char con))) + (ct #f (and (char-ready?) (read-char)))) + ((or (eof-object? cs) (eof-object? ct)) + (close-port con)) + (cond (cs (display cs))) + (cond (ct (file-set-position con 0) + (display ct con) + (file-set-position con 0)))) +@end example + + +@node The Implementation, Procedure and Macro Index, Packages, Top +@chapter The Implementation + +@menu +* Data Types:: +* Operations:: +* Improvements To Make:: +* Finishing Dynamic Linking:: +@end menu + +@node Data Types, Operations, The Implementation, The Implementation +@section Data Types + +@noindent +In the descriptions below it is assumed that @code{long int}s are 32 +bits in length. Acutally, SCM is written to work with any @code{long +int} size larger than 31 bits. With some modification, SCM could work +with word sizes as small as 24 bits. + +@noindent +All SCM objects are represented by type @dfn{SCM}. Type @code{SCM} come +in 2 basic flavors, Immediates and Cells: + +@menu +* Immediates:: +* Cells:: Non-Immediate types +* Header Cells:: Malloc objects +* Subr Cells:: Built-in and Compiled Procedures +* Ptob Cells:: I/O ports +* Smob Cells:: Miscellaneous datatypes +* Data Type Representations:: How they all fit together +@end menu + +@node Immediates, Cells, Data Types, Data Types +@subsection Immediates + +@noindent +An @dfn{immediate} is a data type contained in type @code{SCM} +(@code{long int}). The type codes distinguishing immediate types from +each other vary in length, but reside in the low order bits. + +@defmac IMP x +@defmacx NIMP x +Return non-zero if the @code{SCM} object @var{x} is an immediate or +non-immediate type, respectively. +@end defmac + +@deftp Immediate inum +immediate 30 bit signed integer. An INUM is flagged by a @code{1} in +the second to low order bit position. The high order 30 bits are used +for the integer's value. + +@defmac INUMP x +@defmacx NINUMP x +Return non-zero if the @code{SCM} @var{x} is an immediate integer or not +an immediate integer, respectively. +@end defmac + +@defmac INUM x +Returns the C @code{long integer} corresponding to @code{SCM} @var{x}. +@end defmac + +@defmac MAKINUM x +Returns the @code{SCM} inum corresponding to C @code{long integer} x. +@end defmac + +@defvr {Immediate Constant} INUM0 +is equivalent to @code{MAKINUM(0)}. +@end defvr + +Computations on INUMs are performed by converting the arguments to C +integers (by a shift), operating on the integers, and converting the +result to an inum. The result is checked for overflow by converting +back to integer and checking the reverse operation. + +The shifts used for conversion need to be signed shifts. If the C +implementation does not support signed right shift this fact is detected +in a #if statement in @file{scmfig.h} and a signed right shift, +@code{SRS}, is constructed in terms of unsigned right shift. +@end deftp + +@deftp Immediate ichr +characters. + +@defmac ICHRP x +Return non-zero if the @code{SCM} object @var{x} is a character. +@end defmac + +@defmac ICHR x +Returns corresponding @code{unsigned char}. +@end defmac + +@defmac MAKICHR x +Given @code{char} @var{x}, returns @code{SCM} character. +@end defmac + +@end deftp + +@deftp Immediate iflags +These are frequently used immediate constants. +@deftypevr {Immediate Constant} SCM BOOL_T +@code{#t} +@end deftypevr +@deftypevr {Immediate Constant} SCM BOOL_F +@code{#f} +@end deftypevr +@deftypevr {Immediate Constant} SCM EOL +@code{()}. If @code{SICP} is @code{#define}d, @code{EOL} is +@code{#define}d to be identical with @code{BOOL_F}. In this case, both +print as @code{#f}. +@end deftypevr +@deftypevr {Immediate Constant} SCM EOF_VAL +end of file token, @code{#<eof>}. +@end deftypevr +@deftypevr {Immediate Constant} SCM UNDEFINED +@code{#<undefined>} used for variables which have not been defined and +absent optional arguments. +@end deftypevr +@deftypevr {Immediate Constant} SCM UNSPECIFIED +@code{#<unspecified>} is returned for those procedures whose return +values are not specified. +@end deftypevr + +@end deftp + +@defmac IFLAGP n +Returns non-zero if @var{n} is an ispcsym, isym or iflag. +@end defmac + +@defmac ISYMP n +Returns non-zero if @var{n} is an ispcsym or isym. +@end defmac + +@defmac ISYMNUM n +Given ispcsym, isym, or iflag @var{n}, returns its index in the C array +@code{isymnames[]}. +@end defmac + +@defmac ISYMCHARS n +Given ispcsym, isym, or iflag @var{n}, returns its @code{char *} +representation (from @code{isymnames[]}). +@end defmac + +@defmac MAKSPCSYM n +Returns @code{SCM} ispcsym @var{n}. +@end defmac + +@defmac MAKISYM n +Returns @code{SCM} iisym @var{n}. +@end defmac + +@defmac MAKIFLAG n +Returns @code{SCM} iflag @var{n}. +@end defmac + +@defvar isymnames +An array of strings containing the external representations of all the +ispcsym, isym, and iflag immediates. Defined in @file{repl.c}. +@end defvar + +@defvr Constant NUM_ISPCSYM +@defvrx Constant NUM_ISYMS +The number of ispcsyms and ispcsyms+isyms, respectively. Defined in +@file{scm.h}. +@end defvr + +@deftp Immediate isym +@code{and}, @code{begin}, @code{case}, @code{cond}, @code{define}, +@code{do}, @code{if}, @code{lambda}, @code{let}, @code{let*}, +@code{letrec}, @code{or}, @code{quote}, @code{set!}, @code{#f}, +@code{#t}, @code{#<undefined>}, @code{#<eof>}, @code{()}, and +@code{#<unspecified>}. + +@deftpx {CAR Immediate} ispcsym +special symbols: syntax-checked versions of first 14 isyms +@end deftp + +@deftp {CAR Immediate} iloc +indexes to a variable's location in environment +@end deftp + +@deftp {CAR Immediate} gloc +pointer to a symbol's value cell +@end deftp + +@deftp Immediate CELLPTR +pointer to a cell (not really an immediate type, but here for +completeness). Since cells are always 8 byte aligned, a pointer to a +cell has the low order 3 bits @code{0}. + +There is one exception to this rule, @emph{CAR Immediate}s, described +next. +@end deftp + +@noindent +A @dfn{CAR Immediate} is an Immediate point which can only occur in the +@code{CAR}s of evaluated code (as a result of @code{ceval}'s memoization +process). + +@node Cells, Header Cells, Immediates, Data Types +@subsection Cells + +@noindent +@dfn{Cell}s represent all SCM objects other than immediates. A cell has +a @code{CAR} and a @code{CDR}. Low-order bits in @code{CAR} identify +the type of object. The rest of @code{CAR} and @code{CDR} hold object +data. The number after @code{tc} specifies how many bits are in the +type code. For instance, @code{tc7} indicates that the type code is 7 +bits. + +@defmac NEWCELL x +Allocates a new cell and stores a pointer to it in @code{SCM} local +variable @var{x}. + +Care needs to be taken that stores into the new cell pointed to by +@var{x} do not create an inconsistent object. @xref{Signals}. +@end defmac + +@noindent +All of the C macros decribed in this section assume that their argument +is of type @code{SCM} and points to a cell (@code{CELLPTR}). + +@defmac CAR x +@defmacx CDR x +Returns the @code{car} and @code{cdr} of cell @var{x}, respectively. +@end defmac + +@defmac TYP3 x +@defmacx TYP7 x +@defmacx TYP16 x +Returns the 3, 7, and 16 bit type code of a cell. +@end defmac + +@deftp Cell tc3_cons +scheme cons-cell returned by (cons arg1 arg2). + +@defmac CONSP x +@defmacx NCONSP x +Returns non-zero if @var{x} is a @code{tc3_cons} or isn't, respectively. +@end defmac +@end deftp + +@deftp Cell tc3_closure +applicable object returned by (lambda (args) @dots{}). +@code{tc3_closure}s have a pointer to other the body of the procedure in +the @code{CAR} and a pointer to the environment in the @code{CDR}. + +@defmac CLOSUREP x +Returns non-zero if @var{x} is a @code{tc3_closure}. +@end defmac + +@defmac CODE x +@defmacx ENV x +Returns the code body or environment of closure @var{x}, respectively. +@end defmac + +@end deftp + +@node Header Cells, Subr Cells, Cells, Data Types +@subsection Header Cells + +@noindent +@dfn{Header}s are Cells whose @code{CDR}s point elsewhere in memory, +such as to memory allocated by @code{malloc}. + +@deftp Header spare +spare @code{tc7} type code +@end deftp + +@deftp Header tc7_vector +scheme vector. + +@defmac VECTORP x +@defmacx NVECTORP x +Returns non-zero if @var{x} is a @code{tc7_vector} or if not, respectively. +@end defmac + +@defmac VELTS x +@defmacx LENGTH x +Returns the C array of @code{SCM}s holding the elements of vector +@var{x} or its length, respectively. +@end defmac +@end deftp + +@deftp Header tc7_ssymbol +static scheme symbol (part of initial system) + +@deftpx Header tc7_msymbol +@code{malloc}ed scheme symbol (can be GCed) + +@defmac SYMBOLP x +Returns non-zero if @var{x} is a @code{tc7_ssymbol} or +@code{tc7_msymbol}. +@end defmac + +@defmac CHARS x +@defmacx UCHARS x +@defmacx LENGTH x +Returns the C array of @code{char}s or as @code{unsigned char}s holding +the elements of symbol @var{x} or its length, respectively. +@end defmac +@end deftp + +@deftp Header tc7_string +scheme string + +@defmac STRINGP x +@defmacx NSTRINGP x +Returns non-zero if @var{x} is a @code{tc7_string} or isn't, +respectively. +@end defmac + +@defmac CHARS x +@defmacx UCHARS x +@defmacx LENGTH x +Returns the C array of @code{char}s or as @code{unsigned char}s holding +the elements of string @var{x} or its length, respectively. +@end defmac +@end deftp + +@deftp Header tc7_bvect +uniform vector of booleans (bit-vector) +@end deftp + +@deftp Header tc7_ivect +uniform vector of integers +@end deftp + +@deftp Header tc7_uvect +uniform vector of non-negative integers +@end deftp + +@deftp Header tc7_fvect +uniform vector of short inexact real numbers +@end deftp + +@deftp Header tc7_dvect +uniform vector of double precision inexact real numbers +@end deftp + +@deftp Header tc7_cvect +uniform vector of double precision inexact complex numbers +@end deftp + +@deftp Header tc7_contin +applicable object produced by call-with-current-continuation +@end deftp + +@deftp Header tc7_cclo +Subr and environment for compiled closure + +A cclo is similar to a vector (and is GCed like one), but can be applied +as a function: + +@enumerate +@item +the cclo itself is consed onto the head of the argument list +@item +the first element of the cclo is applied to that list. Cclo invocation +is currently not tail recursive when given 2 or more arguments. +@end enumerate + +@defun makcclo proc len +makes a closure from the @emph{subr} @var{proc} with @var{len}-1 extra +locations for @code{SCM} data. Elements of a @var{cclo} are referenced +using @code{VELTS(cclo)[n]} just as for vectors. +@end defun +@end deftp + +@node Subr Cells, Ptob Cells, Header Cells, Data Types +@subsection Subr Cells + +@noindent +A @dfn{Subr} is a header whose @code{CDR} points to a C code procedure. +Scheme primitive procedures are subrs. Except for the arithmetic +@code{tc7_cxr}s, the C code procedures will be passed arguments (and +return results) of type @code{SCM}. + +@deftp Subr tc7_asubr +associative C function of 2 arguments. Examples are @code{+}, @code{-}, +@code{*}, @code{/}, @code{max}, and @code{min}. +@end deftp + +@deftp Subr tc7_subr_0 +C function of no arguments. +@end deftp + +@deftp Subr tc7_subr_1 +C function of one argument. +@end deftp + +@deftp Subr tc7_cxr +These subrs are handled specially. If inexact numbers are enabled, the +@code{CDR} should be a function which takes and returns type +@code{double}. Conversions are handled in the interpreter. + +@code{floor}, @code{ceiling}, @code{truncate}, @code{round}, +@code{$sqrt}, @code{$abs}, @code{$exp}, @code{$log}, @code{$sin}, +@code{$cos}, @code{$tan}, @code{$asin}, @code{$acos}, @code{$atan}, +@code{$sinh}, @code{$cosh}, @code{$tanh}, @code{$asinh}, @code{$acosh}, +@code{$atanh}, and @code{exact->inexact} are defined this way. + +If the @code{CDR} is @code{0} (@code{NULL}), the name string of the +procedure is used to control traversal of its list structure argument. + +@code{car}, @code{cdr}, @code{caar}, @code{cadr}, @code{cdar}, +@code{cddr}, @code{caaar}, @code{caadr}, @code{cadar}, @code{caddr}, +@code{cdaar}, @code{cdadr}, @code{cddar}, @code{cdddr}, @code{caaaar}, +@code{caaadr}, @code{caadar}, @code{caaddr}, @code{cadaar}, +@code{cadadr}, @code{caddar}, @code{cadddr}, @code{cdaaar}, +@code{cdaadr}, @code{cdadar}, @code{cdaddr}, @code{cddaar}, +@code{cddadr}, @code{cdddar}, and @code{cddddr} are defined this way. +@end deftp + +@deftp Subr tc7_subr_3 +C function of 3 arguments. +@end deftp + +@deftp Subr tc7_subr_2 +C function of 2 arguments. +@end deftp + +@deftp Subr tc7_rpsubr +transitive relational predicate C function of 2 arguments. The C +function should return either @code{BOOL_T} or @code{BOOL_F}. +@end deftp + +@deftp Subr tc7_subr_1o +C function of one optional argument. If the optional argument is not +present, @code{UNDEFINED} is passed in its place. +@end deftp + +@deftp Subr tc7_subr_2o +C function of 1 required and 1 optional argument. If the optional +argument is not present, @code{UNDEFINED} is passed in its place. +@end deftp + +@deftp Subr tc7_lsubr_2 +C function of 2 arguments and a list of (rest of) @code{SCM} arguments. +@end deftp + +@deftp Subr tc7_lsubr +C function of list of @code{SCM} arguments. +@end deftp + +@node Ptob Cells, Smob Cells, Subr Cells, Data Types +@subsection Ptob Cells + +@noindent +A @dfn{ptob} is a port object, capable of delivering or accepting +characters. @xref{Ports, , , r4rs, Revised(4) Report on the Algorithmic +Language Scheme}. Unlike the types described so far, new varieties of +ptobs can be defined dynamically (@pxref{Defining Ptobs}). These are +the initial ptobs: + +@deftp ptob tc16_inport +input port. +@end deftp + +@deftp ptob tc16_outport +output port. +@end deftp + +@deftp ptob tc16_ioport +input-output port. +@end deftp + +@deftp ptob tc16_inpipe +input pipe created by @code{popen()}. +@end deftp + +@deftp ptob tc16_outpipe +output pipe created by @code{popen()}. +@end deftp + +@deftp ptob tc16_strport +String port created by @code{cwos()} or @code{cwis()}. +@end deftp + +@deftp ptob tc16_sfport +Software (virtual) port created by @code{mksfpt()} (@pxref{Soft Ports}). +@end deftp + +@defmac PORTP x +@defmacx OPPORTP x +@defmacx OPINPORTP x +@defmacx OPOUTPORTP x +@defmacx INPORTP x +@defmacx OUTPORTP x +Returns non-zero if @var{x} is a port, open port, open input-port, open +output-port, input-port, or output-port, respectively. +@end defmac + +@defmac OPENP x +@defmacx CLOSEDP x +Returns non-zero if port @var{x} is open or closed, respectively. +@end defmac + +@defmac STREAM x +Returns the @code{FILE *} stream for port @var{x}. +@end defmac + +@noindent +Ports which are particularly well behaved are called @dfn{fport}s. +Advanced operations like @code{file-position} and @code{reopen-file} +only work for fports. + +@defmac FPORTP x +@defmacx OPFPORTP x +@defmacx OPINFPORTP x +@defmacx OPOUTFPORTP x +Returns non-zero if @var{x} is a port, open port, open input-port, or +open output-port, respectively. +@end defmac + +@node Smob Cells, Data Type Representations, Ptob Cells, Data Types +@subsection Smob Cells + +@noindent +A @dfn{smob} is a miscellaneous datatype. The type code and GCMARK bit +occupy the lower order 16 bits of the @code{CAR} half of the cell. The +rest of the @code{CAR} can be used for sub-type or other information. +The @code{CDR} contains data of size long and is often a pointer to +allocated memory. + +@noindent +Like ptobs, new varieties of smobs can be defined dynamically +(@pxref{Defining Smobs}). These are the initial smobs: + +@deftp smob tc_free_cell +unused cell on the freelist. +@end deftp + +@deftp smob tc16_flo +single-precision float. + +Inexact number data types are subtypes of type @code{tc16_flo}. If the +sub-type is: + +@enumerate 0 +@item +a single precision float is contained in the @code{CDR}. +@item +@code{CDR} is a pointer to a @code{malloc}ed double. +@end enumerate +@enumerate 3 +@item +@code{CDR} is a pointer to a @code{malloc}ed pair of doubles. +@end enumerate + +@deftp smob tc_dblr +double-precision float. +@end deftp + +@deftp smob tc_dblc +double-precision complex. +@end deftp +@end deftp + +@deftp smob tc16_bigpos +@deftpx smob tc16_bigneg +positive and negative bignums, respectively. + +Scm has large precision integers called bignums. They are stored in +sign-magnitude form with the sign occuring in the type code of the SMOBs +bigpos and bigneg. The magnitude is stored as a @code{malloc}ed array +of type @code{BIGDIG} which must be an unsigned integral type with size +smaller than @code{long}. @code{BIGRAD} is the radix associated with +@code{BIGDIG}. +@end deftp + +@deftp smob tc16_promise +made by DELAY. @xref{Control features, , , r4rs, Revised(4) Scheme}. +@end deftp + +@deftp smob tc16_arbiter +synchronization object. @xref{Process Synchronization}. +@end deftp + +@deftp smob tc16_macro +macro expanding function. @xref{Low Level Syntactic Hooks}. +@end deftp + +@deftp smob tc16_array +multi-dimensional array. @xref{Arrays}. + +This type implements both conventional arrays (those with arbitrary data +as elements @pxref{Conventional Arrays}) and uniform arrays (those with +elements of a uniform type @pxref{Uniform Array}). + +Conventional Arrays have a pointer to a vector for their @code{CDR}. +Uniform Arrays have a pointer to a Uniform Vector type (string, bvect, +ivect, uvect, fvect, dvect, or cvect) in their @code{CDR}. +@end deftp + + +@node Data Type Representations, , Smob Cells, Data Types +@subsection Data Type Representations + +@format +@r{IMMEDIATE: B,D,E,F=data bit, C=flag code, P=pointer address bit} +@t{ ................................ +inum BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB10 +ichr BBBBBBBBBBBBBBBBBBBBBBBB11110100 +iflag CCCCCCC101110100 +isym CCCCCCC001110100} +@r{ IMCAR: only in car of evaluated code, cdr has cell's GC bit} +@t{ispcsym 000CCCC00CCCC100 +iloc 0DDDDDDDDDDDDDDDEFFFFFFF11111100 +pointer PPPPPPPPPPPPPPPPPPPPPPPPPPPPP000 +gloc PPPPPPPPPPPPPPPPPPPPPPPPPPPPP001} + +@r{ HEAP CELL: G=gc_mark; 1 during mark, 0 other times. + 1s and 0s here indicate type. G missing means sys (not GC'd) + SIMPLE:} +@t{cons ..........SCM car..............0 ...........SCM cdr.............G +closure ..........SCM code...........011 ...........SCM env.............G + HEADERs: +ssymbol .........long length....G0000101 ..........char *chars........... +msymbol .........long length....G0000111 ..........char *chars........... +string .........long length....G0001101 ..........char *chars........... +vector .........long length....G0001111 ...........SCM **elts........... +bvect .........long length....G0010101 ..........long *words........... + spare G0010111 +ivect .........long length....G0011101 ..........long *words........... +uvect .........long length....G0011111 ......unsigned long *words...... + spare G0100101 + spare G0100111 +fvect .........long length....G0101101 .........float *words........... +dvect .........long length....G0101111 ........double *words........... +cvect .........long length....G0110101 ........double *words........... + +contin .........long length....G0111101 .............*regs.............. +cclo .........long length....G0111111 ...........SCM **elts...........} +@r{ SUBRs:} +@t{ spare 010001x1 + spare 010011x1 +subr_0 ..........int hpoff.....01010101 ...........SCM (*f)()........... +subr_1 ..........int hpoff.....01010111 ...........SCM (*f)()........... +cxr ..........int hpoff.....01011101 .........double (*f)().......... +subr_3 ..........int hpoff.....01011111 ...........SCM (*f)()........... +subr_2 ..........int hpoff.....01100101 ...........SCM (*f)()........... +asubr ..........int hpoff.....01100111 ...........SCM (*f)()........... +subr_1o ..........int hpoff.....01101101 ...........SCM (*f)()........... +subr_2o ..........int hpoff.....01101111 ...........SCM (*f)()........... +lsubr_2 ..........int hpoff.....01110101 ...........SCM (*f)()........... +lsubr_2n..........int hpoff.....01110111 ...........SCM (*f)()........... +rpsubr ..........int hpoff.....01111101 ...........SCM (*f)()...........} +@r{ PTOBs:} +@t{ port 0bwroxxxxxxxxG1110111 ..........FILE *stream.......... + socket ttttttt 00001xxxxxxxxG1110111 ..........FILE *stream.......... + inport uuuuuuuuuuU00011xxxxxxxxG1110111 ..........FILE *stream.......... +outport 0000000000000101xxxxxxxxG1110111 ..........FILE *stream.......... + ioport uuuuuuuuuuU00111xxxxxxxxG1110111 ..........FILE *stream.......... +fport 00 00000000G1110111 ..........FILE *stream.......... +pipe 00 00000001G1110111 ..........FILE *stream.......... +strport 00 00000010G1110111 ..........FILE *stream.......... +sfport 00 00000011G1110111 ..........FILE *stream..........} +@r{ SMOBs:} +@t{free_cell + 000000000000000000000000G1111111 ...........*free_cell........000 +flo 000000000000000000000001G1111111 ...........float num............ +dblr 000000000000000100000001G1111111 ..........double *real.......... +dblc 000000000000001100000001G1111111 .........complex *cmpx.......... +bignum ...int length...0000001 G1111111 .........short *digits.......... +bigpos ...int length...00000010G1111111 .........short *digits.......... +bigneg ...int length...00000011G1111111 .........short *digits.......... + xxxxxxxx = code assigned by newsmob(); +promise 000000000000000fxxxxxxxxG1111111 ...........SCM val.............. +arbiter 000000000000000lxxxxxxxxG1111111 ...........SCM name............. +macro 000000000000000mxxxxxxxxG1111111 ...........SCM name............. +array ...short rank..cxxxxxxxxG1111111 ............*array..............} +@end format + +@node Operations, Improvements To Make, Data Types, The Implementation +@section Operations + +@menu +* Garbage Collection:: Automatically reclaims unused storage +* Signals:: +* C Macros:: +* Changing Scm:: +* Defining Subrs:: +* Defining Smobs:: +* Defining Ptobs:: +* Calling Scheme From C:: +* Callbacks:: +* Type Conversions:: For use with C code. +* Continuations:: For C and SCM +* Evaluation:: Why SCM is fast +@end menu + +@node Garbage Collection, Signals, Operations, Operations +@subsection Garbage Collection + +The garbage collector is in the latter half of @file{sys.c}. The +primary goal of @dfn{garbage collection} (or @dfn{GC}) is to recycle +those cells no longer in use. Immediates always appear as parts of +other objects, so they are not subject to explicit garbage collection. + +All cells reside in the @dfn{heap} (composed of @dfn{heap segments}). +Note that this is different from what Computer Science usually defines +as a heap. + +@menu +* Marking Cells:: +* Sweeping the Heap:: +@end menu + +@node Marking Cells, Sweeping the Heap, Garbage Collection, Garbage Collection +@subsubsection Marking Cells + +The first step in garbage collection is to @dfn{mark} all heap objects +in use. Each heap cell has a bit reserved for this purpose. For pairs +(cons cells) the lowest order bit (0) of the CDR is used. For other +types, bit 8 of the CAR is used. The GC bits are never set except +during garbage collection. Special C macros are defined in @file{scm.h} +to allow easy manipulation when GC bits are possibly set. @code{CAR}, +@code{TYP3}, and @code{TYP7} can be used on GC marked cells as they are. + +@defmac GCCDR x +Returns the CDR of a cons cell, even if that cell has been GC marked. +@end defmac +@defmac GCTYP16 x +Returns the 16 bit type code of a cell. +@end defmac + +We need to (recursively) mark only a few objects in order to assure that +all accessible objects are marked. Those objects are +@code{sys_protects[]} (for example, @code{dynwinds}), the current +C-stack and the hash table for symbols, @dfn{symhash}. + +@deftypefun void gc_mark (SCM @var{obj}) +The function @code{gc_mark()} is used for marking SCM cells. If +@var{obj} is marked, @code{gc_mark()} returns. If @var{obj} is +unmarked, gc_mark sets the mark bit in @var{obj}, then calls +@code{gc_mark()} on any SCM components of @var{obj}. The last call to +@code{gc_mark()} is tail-called (looped). +@end deftypefun + +@deftypefun void mark_locations (STACKITEM @var{x[]}, sizet @var{len})) +The function @code{mark_locations} is used for marking segments of +C-stack or saved segments of C-stack (marked continuations). The +argument @var{len} is the size of the stack in units of size +@code{(STACKITEM)}. + +Each longword in the stack is tried to see if it is a valid cell pointer +into the heap. If it is, the object itself and any objects it points to +are marked using @code{gc_mark}. If the stack is word rather than +longword aligned @code{(#define WORD_ALIGN)}, both alignments are tried. +This arrangement will occasionally mark an object which is no longer +used. This has not been a problem in practice and the advantage of +using the c-stack far outweighs it. +@end deftypefun + +@node Sweeping the Heap, , Marking Cells, Garbage Collection +@subsubsection Sweeping the Heap + +After all found objects have been marked, the heap is swept. + +The storage for strings, vectors, continuations, doubles, complexes, and +bignums is managed by malloc. There is only one pointer to each malloc +object from its type-header cell in the heap. This allows malloc +objects to be freed when the associated heap object is garbage +collected. + +@deftypefun static void gc_sweep () +The function @code{gc_sweep} scans through all heap segments. The mark +bit is cleared from marked cells. Unmarked cells are spliced into +@var{freelist}, where they can again be returned by invocations of +@code{NEWCELL}. + +If a type-header cell pointing to malloc space is unmarked, the malloc +object is freed. If the type header of smob is collected, the smob's +@code{free} procedure is called to free its storage. +@end deftypefun + +@node Signals, C Macros, Garbage Collection, Operations +@subsection Signals + +@defun init_signals +(in @file{scm.c}) initializes handlers for @code{SIGINT} and +@code{SIGALRM} if they are supported by the C implementation. All of +the signal handlers immediately reestablish themselves by a call to +@code{signal()}. +@end defun + +@defun int_signal sig +@defunx alrm_signal sig +The low level handlers for @code{SIGINT} and @code{SIGALRM}. +@end defun + +If an interrupt handler is defined when the interrupt is received, the +code is interpreted. If the code returns, execution resumes from where +the interrupt happened. @code{Call-with-current-continuation} allows +the stack to be saved and restored. + +SCM does not use any signal masking system calls. These are not a +portable feature. However, code can run uninterrupted by use of the C +macros @code{DEFER_INTS} and @code{ALLOW_INTS}. + +@defmac DEFER_INTS +sets the global variable @code{ints_disabled} to 1. If an interrupt +occurs during a time when @code{ints_disabled} is 1 one of the global +variables @code{sig_deferred} or @code{alrm_deferred} is set to 1 and +the handler returns. + +@defmacx ALLOW_INTS +Checks the deferred variables and if set the appropriate handler is +called. + +Calls to @code{DEFER_INTS} can not be nested. An @code{ALLOW_INTS} must +happen before another @code{DEFER_INTS} can be done. In order to check +that this constraint is satisfied @code{#define CAREFUL_INTS} in +@file{scmfig.h}. +@end defmac + +@node C Macros, Changing Scm, Signals, Operations +@subsection C Macros + + +@defmac ASSERT cond arg pos subr +signals an error if the expression (@var{cond}) is 0. @var{arg} is the +offending object, @var{subr} is the string naming the subr, and +@var{pos} indicates the position or type of error. @var{pos} can be one +of + +@itemize @bullet +@item @code{ARGn} @i{(> 5 or unknown ARG number)} +@item @code{ARG1} +@item @code{ARG2} +@item @code{ARG3} +@item @code{ARG4} +@item @code{ARG5} +@item @code{WNA} @i{(wrong number of args)} +@item @code{OVFLOW} +@item @code{OUTOFRANGE} +@item @code{NALLOC} +@item @code{EXIT} +@item @code{HUP_SIGNAL} +@item @code{INT_SIGNAL} +@item @code{FPE_SIGNAL} +@item @code{BUS_SIGNAL} +@item @code{SEGV_SIGNAL} +@item @code{ALRM_SIGNAL} +@item a C string @code{(char *)} +@end itemize + +Error checking is not done by @code{ASSERT} if the flag @code{RECKLESS} +is defined. An error condition can still be signaled in this case with +a call to @code{wta(arg, pos, subr)}. +@end defmac + +@defmac ASRTGO cond label +@code{goto} @var{label} if the expression (@var{cond}) is 0. Like +@code{ASSERT}, @code{ASRTGO} does is not active if the flag +@code{RECKLESS} is defined. +@end defmac + + +@node Changing Scm, Defining Subrs, C Macros, Operations +@subsection Changing Scm + +@noindent +When writing C-code for SCM, a precaution is recommended. If your +routine allocates a non-cons cell which will @emph{not} be incorporated +into a @code{SCM} object which is returned, you need to make sure that a +@code{SCM} variable in your routine points to that cell as long as part +of it might be referenced by your code. + +@noindent +In order to make sure this @code{SCM} variable does not get optimized +out you can put this assignment after its last possible use: + +@example +SCM_dummy1 = @i{foo}; +@end example + +@noindent +or put this assignment somewhere in your routine: + +@example +SCM_dummy1 = (SCM) &@i{foo}; +@end example + +@noindent +@code{SCM_dummy} variables are not currently defined. Passing the +address of the local @code{SCM} variable to @emph{any} procedure also +protects it. + +@noindent +Also, if you maintain a static pointer to some (non-immediate) +@code{SCM} object, you must either make your pointer be the value cell +of a symbol (see @code{errobj} for an example) or make your pointer be +one of the @code{sys_protects} (see @code{dynwinds} for an example). +The former method is prefered since it does not require any changes to +the SCM distribution. + +@noindent +To add a C routine to scm: + +@enumerate +@item +choose the appropriate subr type from the type list. +@item +write the code and put into @file{scm.c}. +@item +add a @code{make_subr} or @code{make_gsubr} call to @code{init_scm}. Or +put an entry into the appropriate @code{iproc} structure. +@end enumerate + +To add a package of new procedures to scm (see @file{crs.c} for +example): + +@enumerate +@item +create a new C file (@file{@i{foo}.c}). +@item +at the front of @file{@i{foo}.c} put declarations for strings for your +procedure names. + +@example +static char s_twiddle_bits[]="twiddle-bits!"; +static char s_bitsp[]="bits?"; +@end example + +@item +choose the appropriate subr types from the type list in @file{code.doc}. +@item +write the code for the procedures and put into @file{@i{foo}.c} +@item +create one @code{iproc} structure for each subr type used in @file{@i{foo}.c} + +@example +static iproc subr3s[]= @{ + @{s_twiddle-bits,twiddle-bits@}, + @{s_bitsp,bitsp@}, + @{0,0@} @}; +@end example + +@item +create an @code{init_@i{<name of file>}} routine at the end of the file +which calls @code{init_iprocs} with the correct type for each of the +@code{iproc}s created in step 5. + +@example +void init_@i{foo}() +@{ + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr3s, tc7_subr_3); +@} +@end example + +If your package needs to have a @dfn{finalization} routine called to +free up storage, close files, etc, then also have a line in +@code{init_@i{foo}} like: + +@example +add_final(final_@i{foo}); +@end example + +@code{final_@i{foo}} should be a (void) procedure of no arguments. The +finals will be called in opposite order from their definition. + +The line: + +@example +add_feature("@i{foo}"); +@end example + +will append a symbol @code{'@i{foo}} to the (list) value of +@code{*features*}. +@item +put any scheme code which needs to be run as part of your package into +@file{I@i{foo}.scm}. +@item +put an @code{if} into @file{Init.scm} which loads @file{I@i{foo}.scm} if +your package is included: + +@example +(if (defined? twiddle-bits!) + (load (in-vicinity (implementation-vicinity) + "I@i{foo}" + (scheme-file-suffix)))) +@end example + +or use @code{(provided? '@i{foo})} instead of @code{(defined? +twiddle-bits!)} if you have added the feature. +@item +put documentation of the new procedures into @file{@i{foo}.doc} +@item +add lines to your @file{Makefile} to compile and link SCM with your +object file. Add a @code{init_@i{foo}\(\)\;} to the @code{INITS=@dots{}} +line at the beginning of the makefile. +@end enumerate + +@noindent +These steps should allow your package to be linked into SCM with a +minimum of difficulty. Your package should also work with dynamic +linking if your SCM has this capability. + +Special forms (new syntax) can be added to scm. + +@enumerate +@item +define a new @code{MAKISYM} in @file{scm.h} and increment +@code{NUM_ISYMS}. +@item +add a string with the new name in the corresponding place in +@code{isymnames} in @file{repl.c}. +@item +add @code{case:} clause to @code{ceval()} near @code{i_quasiquote} (in +@file{eval.c}). +@end enumerate + +@noindent +New syntax can now be added without recompiling SCM by the use of the +@code{procedure->syntax}, @code{procedure->macro}, +@code{procedure->memoizing-macro}, and @code{defmacro}. For details, +@xref{Syntax Extensions}. + +@node Defining Subrs, Defining Smobs, Changing Scm, Operations +@subsection Defining Subrs + +@noindent +If @dfn{CCLO} is @code{#define}d when compiling, the compiled closure +feature will be enabled. It is automatically enabled if dynamic linking +is enabled. + +@noindent +The SCM interpreter directly recognizes subrs taking small numbers of +arguments. In order to create subrs taking larger numbers of arguments +use: + +@defun make_gsubr name req opt rest fcn +returns a cclo (compiled closure) object of name @code{char *} +@var{name} which takes @code{int} @var{req} required arguments, +@code{int} @var{opt} optional arguments, and a list of rest arguments if +@code{int} @var{rest} is 1 (0 for not). + +@code{SCM (*fcn)()} is a pointer to a C function to do the work. + +The C function will always be called with @var{req} + @var{opt} + +@var{rest} arguments, optional arguments not supplied will be passed +@code{UNDEFINED}. An error will be signaled if the subr is called with +too many or too few arguments. Currently a total of 10 arguments may be +specified, but increasing this limit should not be difficult. + +@example +/* A silly example, taking 2 required args, + 1 optional, and a list of rest args */ + +#include <scm.h> + +SCM gsubr_21l(req1,req2,opt,rst) + SCM req1,req2,opt,rst; +@{ + lputs("gsubr-2-1-l:\n req1: ", cur_outp); + display(req1,cur_outp); + lputs("\n req2: ", cur_outp); + display(req2,cur_outp); + lputs("\n opt: ", cur_outp); + display(opt,cur_outp); + lputs("\n rest: ", cur_outp); + display(rst,cur_outp); + newline(cur_outp); + return UNSPECIFIED; +@} + +void init_gsubr211() +@{ + make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); +@} +@end example +@end defun + +@node Defining Smobs, Defining Ptobs, Defining Subrs, Operations +@subsection Defining Smobs + +@noindent +Here is an example of how to add a new type named @code{@i{foo}} to SCM. +The following lines need to be added to your code: + +@table @code +@item long tc16_@i{foo}; +The type code which will be used to identify the new type. +@item static smobfuns @i{foo}smob = @{mark@i{foo},free@i{foo},print@i{foo},equalp@i{foo}@}; +smobfuns is a structure composed of 4 functions: + +@example +typedef struct @{ + SCM (*mark)P((SCM)); + sizet (*free)P((CELLPTR)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); +@} smobfuns; +@end example + +@table @code +@item smob.mark +is a function of one argument of type @code{SCM} (the cell to mark) and +returns type @code{SCM} which will then be marked. If no further +objects need to be marked then return an immediate object such as +@code{BOOL_F}. 2 functions are provided: + +@table @code +@item markcdr(ptr) +which marks the current cell and returns @code{CDR(ptr)}. +@item mark0(ptr) +which marks the current cell and returns @code{BOOL_F}. +@end table + +@item smob.free +is a function of one argument of type @code{CELLPTR} (the cell to +collected) and returns type @code{sizet} which is the number of +@code{malloc}ed bytes which were freed. @code{Smob.free} should free +any @code{malloc}ed storage associated with this object. The function +free0(ptr) is provided which does not free any storage and returns 0. +@item smob.print +is 0 or a function of 3 arguments. The first, of type @code{SCM}, is +the smob object. The second, of type @code{SCM}, is the stream on which +to write the result. The third, of type int, is 1 if the object should +be @code{write}n, 0 if it should be @code{display}ed. This function +should return non-zero if it printed, and zero otherwise (in which case +a hexadecimal number will be printed). +@item smob.equalp +is 0 or a function of 2 @code{SCM} arguments. Both of these arguments +will be of type @code{tc16@i{foo}}. This function should return +@code{BOOL_T} if the smobs are equal, @code{BOOL_F} if they are not. If +@code{smob.equalp} is 0, @code{equal?} will return @code{BOOL_F} if they +are not @code{eq?}. +@end table + +@item tc16_@i{foo} = newsmob(&@i{foo}smob); +Allocates the new type with the functions from @code{@i{foo}smob}. This +line goes in an @code{init_} routine. +@end table + +@noindent +Promises and macros in @file{eval.c} and arbiters in @file{repl.c} +provide examples of SMOBs. There are a maximum of 256 SMOBs. + +@node Defining Ptobs, Calling Scheme From C, Defining Smobs, Operations +@subsection Defining Ptobs + +@noindent +@dfn{ptob}s are similar to smobs but define new types of port to which +SCM procedures can read or write. The following functions are defined +in the @code{ptobfuns}: + +@example +typedef struct @{ + SCM (*mark)P((SCM ptr)); + int (*free)P((FILE *p)); + int (*print)P((SCM exp, SCM port, int writing)); + SCM (*equalp)P((SCM, SCM)); + int (*fputc)P((int c, FILE *p)); + int (*fputs)P((char *s, FILE *p)); + sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p)); + int (*fflush)P((FILE *stream)); + int (*fgetc)P((FILE *p)); + int (*fclose)P((FILE *p)); +@} ptobfuns; +@end example + +@noindent +The @code{.free} component to the structure takes a @code{FILE *} or +other C construct as its argument, unlike @code{.free} in a smob, which +takes the whole smob cell. Often, @code{.free} and @code{.fclose} can be +the same function. See @code{fptob} and @code{pipob} in @file{sys.c} +for examples of how to define ptobs. + +@node Calling Scheme From C, Callbacks, Defining Ptobs, Operations +@subsection Calling Scheme From C + +@noindent +To use SCM as a whole from another program call @code{init_scm} or +@code{run_scm} as is done in @code{main()} in @file{scm.c}. + +@noindent +In order to call indivdual Scheme procedures from C code more is +required; SCM's storage system needs to be initialized. The simplest +way to do this for a statically linked single-thread program is to: + +@enumerate +@item +make a SCM procedure which calls your code's startup routine. +@item +use the @code{#define RTL} flag when compiling @file{scm.c} to elide +SCM's @code{main()}. +@item +In your @code{main()}, call @code{run_scm} with arguments (@code{argc} +and @code{argv}) to invoke your code's startup routine. +@item +link your code with SCM at compile time. +@end enumerate + +@noindent +For a dynamically linked single-thread program: + +@enumerate +@item +make an @code{init_} procedure for your code which will set up any Scheme +definitions you need and then call your startup routine +(@pxref{Changing Scm}). +@item +Start SCM with command line arguments to dynamically link your code. +After your module is linked, the @code{init_} procedure will be called, and +hence your startup routine. +@end enumerate + +@noindent +Now use @code{apply} (and perhaps @code{intern}) to call Scheme +procedures from your C code. For example: + +@example +/* If this apply fails, SCM will catch the error */ +apply(CDR(intern("srv:startup",sizeof("srv:startup")-1)), + mksproc(srvproc), + listofnull); + +func = CDR(intern(rpcname,strlen(rpcname))); +retval = apply(func, cons(mksproc(srvproc), args), EOL); +@end example + +@node Callbacks, Type Conversions, Calling Scheme From C, Operations +@subsection Callbacks + +@noindent +SCM now has routines to make calling back to Scheme procedures easier. +The source code for these routines are found in @file{rope.c}. + +@deftypefun int scm_ldfile (char *@var{file}) +Loads the Scheme source file @var{file}. Returns 0 if successful, non-0 +if not. This function is used to load SCM's initialization file +@file{Init.scm}. +@end deftypefun + +@deftypefun int scm_ldprog (char *@var{file}) +Loads the Scheme source file @code{(in-vicinity (program-vicinity) +@var{file})}. Returns 0 if successful, non-0 if not. + +This function is useful for compiled code init_ functions to load +non-compiled Scheme (source) files. @code{program-vicinity} is the +directory from which the calling code was loaded (@pxref{Vicinity, , , +slib, SLIB}). +@end deftypefun + +@deftypefun SCM scm_evstr (char *@var{str}) +Returns the result of reading an expression from @var{str} and +evaluating it. +@end deftypefun + +@deftypefun void scm_ldstr (char *@var{str}) +Reads and evaluates all the expressions from @var{str}. +@end deftypefun + +@noindent +If you wish to catch errors during execution of Scheme code, then you +can use a wrapper like this for your Scheme procedures: + +@example +(define (srv:protect proc) + (lambda args + (define result #f) ; put default value here + (call-with-current-continuation + (lambda (cont) + (dynamic-wind (lambda () #t) + (lambda () + (set! result (apply proc args)) + (set! cont #f)) + (lambda () + (if cont (cont #f)))))) + result)) +@end example + +@noindent +Calls to procedures so wrapped will return even if an error occurs. + +@node Type Conversions, Continuations, Callbacks, Operations +@subsection Type Conversions + +These type conversion functions are very useful for connecting SCM and C +code. Most are defined in @file{rope.c}. + +@deftypefun SCM long2num (long @var{n}) +@deftypefunx SCM ulong2num (unsigned long @var{n}) +Return an object of type @code{SCM} corresponding to the @code{long} or +@code{unsigned long} argument @var{n}. If @var{n} cannot be converted, +@code{BOOL_F} is returned. Which numbers can be converted depends on +whether SCM was compiled with the @code{BIGDIG} or @code{FLOATS} flags. + +To convert integer numbers of smaller types (@code{short} or +@code{char}), use the macro @code{MAKINUM(n)}. +@end deftypefun + +@deftypefun long num2long (SCM @var{num}, char *@var{pos}, char *@var{s_caller}) +@deftypefunx unsigned long num2ulong (SCM @var{num}, char *@var{pos}, char *@var{s_caller}) +@deftypefunx unsigned short num2ushort (SCM @var{num}, char *@var{pos}, char *@var{s_caller}) +@deftypefunx unsigned char num2uchar (SCM @var{num}, char *@var{pos}, char *@var{s_caller}) +These functions are used to check and convert @code{SCM} arguments to +the named C type. The first argument @var{num} is checked to see it it +is within the range of the destination type. If so, the converted +number is returned. If not, the @code{ASSERT} macro calls @code{wta} +with @var{num} and strings @var{pos} and @var{s_caller}. For a listing +of useful predefined @var{pos} macros, @xref{C Macros}. + +@emph{Note:} Inexact numbers are accepted only by @code{num2long} and +@code{num2ulong} (for when @code{SCM} is compiled without bignums). To +convert inexact numbers to exact numbers, @xref{Numerical operations, +inexact->exact, , r4rs, Revised(4) Scheme}. +@end deftypefun + +@deftypefun unsigned long scm_addr (SCM @var{args}, char *@var{s_name}) +Returns a pointer (cast to an @code{unsigned long}) to the storage +corresponding to the location accessed by +@code{aref(CAR(args),CDR(args))}. The string @var{s_name} is used in +any messages from error calls by @code{scm_addr}. + +@code{scm_addr} is useful for performing C operations on strings or +other uniform arrays (@pxref{Uniform Array}). + +@emph{Note:} While you use a pointer returned from @code{scm_addr} you +must keep a pointer to the associated @code{SCM} object in a stack +allocated variable or GC-protected location in order to assure that SCM +does not reuse that storage before you are done with it. +@end deftypefun + +@deftypefun SCM makfrom0str (char *@var{src}) +@deftypefunx SCM makfromstr (char *@var{src}, sizet @var{len}) +Return a newly allocated string @code{SCM} object copy of the +null-terminated string @var{src} or the string @var{src} of length +@var{len}, respectively. +@end deftypefun + +@deftypefun SCM makfromstrs (int @var{argc}, char **@var{argv}) +Returns a newly allocated @code{SCM} list of strings corresponding to +the @var{argc} length array of null-terminated strings @var{argv}. If +@var{argv} is less than @code{0}, @var{argv} is assumed to be +@code{NULL} terminated. @code{makfromstrs} is used by @code{run_scm} to +convert the arguments SCM was called with to a @code{SCM} list which is +the value of SCM procedure calls to @code{program-arguments} +(@pxref{System Interface, program-arguments}). +@end deftypefun + +@deftypefun char **makargvfrmstrs (SCM @var{args}, char *@var{s_name}) +Returns a @code{NULL} terminated list of null-terminated strings copied +from the @code{SCM} list of strings @var{args}. The string @var{s_name} +is used in messages from error calls by @code{makargvfrmstrs}. + +@code{makargvfrmstrs} is useful for constructing argument lists suitable +for passing to @code{main} functions. +@end deftypefun + +@deftypefun void must_free_argv (char **@var{argv}) +Frees the storage allocated to create @var{argv} by a call to +@code{makargvfrmstrs}. +@end deftypefun + +@node Continuations, Evaluation, Type Conversions, Operations +@subsection Continuations + +@noindent +The source files @file{continue.h} and @file{continue.c} are designed to +function as an independent resource for programs wishing to use +continuations, but without all the rest of the SCM machinery. The +concept of continuations is explained in @ref{Control features, +call-with-current-continuation, , r4rs, Revised(4) Scheme}. + +@deftp {Data type} CONTINUATION jmpbuf length stkbse other parent +is a @code{typedef}ed structure holding all the information needed to +represent a continuation. The @var{other} slot can be used to hold any +data the user wishes to put there by defining the macro +@code{CONTINUATION_OTHER}. +@end deftp + +@defmac SHORT_ALIGN +If @code{SHORT_ALIGN} is @code{#define}d (in @file{scmfig.h}), then the +it is assumed that pointers in the stack can be aligned on @code{short +int} boundaries. +@end defmac + +@deftp {Data type} STACKITEM +is a pointer to objects of the size specified by @code{SHORT_ALIGN} +being @code{#define}d or not. +@end deftp + +@defmac CHEAP_CONTINUATIONS +If @code{CHEAP_CONTINUATIONS} is @code{#define}d (in @file{scmfig.h}) +each @code{CONTINUATION} has size @code{sizeof CONTINUATION}. +Otherwise, all but @dfn{root} @code{CONTINUATION}s have additional +storage (immediately following) to contain a copy of part of the stack. + +@emph{Note:} On systems with nonlinear stack disciplines (multiple +stacks or non-contiguous stack frames) copying the stack will not work +properly. These systems need to #define @code{CHEAP_CONTINUATIONS} in +@file{scmfig.h}. +@end defmac + +@defmac STACK_GROWS_UP +Expresses which way the stack grows by its being @code{#define}d or not. +@end defmac + +@deftypevar long thrown_value +Gets set to the @var{value} passed to @code{throw_to_continuation}. +@end deftypevar + +@deftypefun long stack_size (STACKITEM *@var{start}) +Returns the number of units of size @code{STACKITEM} which fit between +@var{start} and the current top of stack. No check is done in this +routine to ensure that @var{start} is actually in the current stack +segment. +@end deftypefun + +@deftypefun CONTINUATION *make_root_continuation (STACKITEM *@var{stack_base}) +Allocates (@code{malloc}) storage for a @code{CONTINUATION} of the +current extent of stack. This newly allocated @code{CONTINUATION} is +returned if successful, @code{0} if not. After +@code{make_root_continuation} returns, the calling routine still needs +to @code{setjmp(@var{new_continuation}->jmpbuf)} in order to complete +the capture of this continuation. +@end deftypefun + +@deftypefun CONTINUATION *make_continuation (CONTINUATION *@var{parent_cont}) +Allocates storage for the current @code{CONTINUATION}, copying (or +encapsulating) the stack state from @code{@var{parent_cont}->stkbse} to +the current top of stack. The newly allocated @code{CONTINUATION} is +returned if successful, @code{0}q if not. After +@code{make_continuation} returns, the calling routine still needs to +@code{setjmp(@var{new_continuation}->jmpbuf)} in order to complete the +capture of this continuation. +@end deftypefun + +@deftypefun void free_continuation (CONTINUATION *@var{cont}) +Frees the storage pointed to by @var{cont}. Remember to free storage +pointed to by @code{@var{cont}->other}. +@end deftypefun + +@deftypefun void throw_to_continuation (CONTINUATION *@var{cont}, long @var{value}, CONTINUATION *@var{root_cont}) +Sets @code{thrown_value} to @var{value} and returns from the +continuation @var{cont}. + +If @code{CHEAP_CONTINUATIONS} is @code{#define}d, then +@code{throw_to_continuation} does @code{longjmp(@var{cont}->jmpbuf, val)}. + +If @code{CHEAP_CONTINUATIONS} is not @code{#define}d, the CONTINUATION +@var{cont} contains a copy of a portion of the C stack (whose bound must +be @code{CONT(@var{root_cont})->stkbse}). Then: + +@itemize @bullet +@item +the stack is grown larger than the saved stack, if neccessary. +@item +the saved stack is copied back into it's original position. +@item +@code{longjmp(@var{cont}->jmpbuf, val)}; +@end itemize +@end deftypefun + +@node Evaluation, , Continuations, Operations +@subsection Evaluation + +SCM uses its type representations to speed evaluation. All of the +@code{subr} types (@pxref{Subr Cells}) are @code{tc7} types. Since the +@code{tc7} field is in the low order bit position of the @code{CAR} it +can be retrieved and dispatched on quickly by dereferencing the SCM +pointer pointing to it and masking the result. + +All the SCM @dfn{Special Forms} get translated to immediate symbols +(@code{isym}) the first time they are encountered by the interpreter +(@code{ceval}). The representation of these immediate symbols is +engineered to occupy the same bits as @code{tc7}. All the @code{isym}s +occur only in the @code{CAR} of lists. + +If the @code{CAR} of a expression to evaluate is not immediate, then it +may be a symbol. If so, the first time it is encountered it will be +converted to an immediate type @code{ILOC} or @code{GLOC} +(@pxref{Immediates}). The codes for @code{ILOC} and @code{GLOC} lower 7 +bits distinguish them from all the other types we have discussed. + +Once it has determined that the expression to evaluate is not immediate, +@code{ceval} need only retrieve and dispatch on the low order 7 bits of +the @code{CAR} of that cell, regardless of whether that cell is a +closure, header, or subr, or a cons containing @code{ILOC} or +@code{GLOC}. + +In order to be able to convert a SCM symbol pointer to an immediate @code{ILOC} +or @code{GLOC}, the evaluator must be holding the pointer to the list in which +that symbol pointer occurs. Turning this requirement to an advantage, +@code{ceval} does not recursively call itself to evaluate symbols in +lists; It instead calls the macro @dfn{EVALCAR}. @code{EVALCAR} does +symbol lookup and memoization for symbols, retrieval of values for @code{ILOC}s +and @code{GLOC}s, returns other immediates, and otherwise recursively calls +itself with the @code{CAR} of the list. + +@code{ceval} inlines evaluation (using @code{EVALCAR}) of almost all +procedure call arguments. When @code{ceval} needs to evaluate a list of +more than length 3, the procedure @code{eval_args} is called. So +@code{ceval} can be said to have one level lookahead. The avoidance of +recursive invocations of @code{ceval} for the most common cases (special +forms and procedure calls) results in faster execution. The speed of +the interpreter is currently limited on most machines by interpreter +size, probably having to do with its cache footprint. In order to keep +the size down, certain @code{EVALCAR} calls which don't need to be fast +(because they rarely occur or because they are part of expensive +operations) are instead calls to the C function @code{evalcar}. + +There was some discussion a year ago about a "Forth" style Scheme +interpreter. This is the only improvement I know of which would beat +SCM in speed. + +@quotation +Provided there is still type code space available in SCM, if we devote +some of the IMCAR codes to "inlined" operations, we should get a +significant performance boost. What is eliminated is the having to look +up a @code{GLOC} or @code{ILOC} and then dispatch on the subr type. The +IMCAR operation would be dispatched to directly. Another way to view +this is that we make available special form versions of @code{CAR}, +@code{CDR}, etc. Since the actual operation code is localized in the +interpreter, it is much easier than uncompilation and then recompilation +to handle @code{(trace car)}; For instance a switch gets set which tells +the interpreter to instead always look up the values of the associated +symbols. +@end quotation + +@defvar symhash +Top level symbol values are stored in the @code{symhash} table. +@code{symhash} is an array of lists of @code{ISYM}s and pairs of symbols +and values. +@end defvar + +@deftp Immediate ILOC +Whenever a symbol's value is found in the local environment the pointer +to the symbol in the code is replaced with an immediate object +(@code{ILOC}) which specifies how many environment frames down and how +far in to go for the value. When this immediate object is subsequently +encountered, the value can be retrieved quickly. +@end deftp + +@deftp Immediate GLOC +Pointers to symbols not defined in local environments are changed to one +plus the value cell address in symhash. This incremented pointer is +called a @code{GLOC}. The low order bit is normally reserved for +GCmark; But, since references to variables in the code always occur in +the @code{CAR} position and the GCmark is in the @code{CDR}, there is no +conflict. +@end deftp + +If the compile FLAG @code{CAUTIOUS} is #defined then the number of +arguments is always checked for application of closures. If the compile +FLAG @code{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 +@code{ILOC} or @code{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 @code{ILOC} or @code{GLOC}. + +@defmac EVAL expression env +@defmacx SIDEVAL expression env +@code{EVAL} Returns the result of evaluating @var{expression} in +@var{env}. @code{SIDEVAL} evaluates @var{expression} in @var{env} when +the value of the expression is not used. + +Both of these macros alter the list structure of @var{expression} as it +is memoized and hence should be used only when it is known that +@var{expression} will not be referenced again. The C function +@code{eval} is safe from this problem. +@end defmac + +@deftypefun SCM eval (SCM @var{expression}) +Returns the result of evaluating @var{expression} in the top-level +environment. @code{eval} copies @code{expression} so that memoization +does not modify @code{expression}. +@end deftypefun + +@node Improvements To Make, Finishing Dynamic Linking, Operations, The Implementation +@section Improvements To Make + +@itemize @bullet +@item +Prefix and make more uniform all C function, variable, and constant +names. Provide a file full of #define's to provide backward +compatability. +@item +@code{lgcd()} @emph{needs} to generate at most one bignum, but currently +generates more. +@item +@code{divide()} could use shifts instead of multiply and divide when +scaling. +@item +If an open fails because there are no unused file handles, GC should +be done so that file handles which are no longer used can be +collected. +@item +Currently, @code{dump}ing an executable does not preserve ports. When +loading a @code{dump}ed executable, disk files could be reopened to the +same file and position as they had when the executable was dumped. +@item +Compaction could be done to @code{malloc}ed objects by freeing and +reallocing all the malloc objects encountered in a scan of the heap. +Whether compactions would actually occur is system depenedent. +@item +Copying all of the stack is wasteful of storage. Any time a +call-with-current-continuation is called the stack could be re-rooted +with a frame which calls the contin just created. This in combination +with checking stack depth could also be used to allow stacks deeper +than 64K on the IBM PC. +@item +lookupcar in @file{eval.c} should @emph{not} memoize (to @code{ILOC}s) +when it retrieves environments deeper or longer than 4095. The values +can still be retrieved (albeit slowly), but an @code{ILOC} should not be +made. The @code{MEMOIZE_LOCALS} flag could then be flushed. +@item +The @code{must-} or @code{make-} routines need some sort of C macros or +conditionalization so that they check: + +@itemize @bullet +@item +that the @code{LENGTH} field fits into a @code{size_t} (as is checked +now) for platforms with @code{(sizeof(size_t) < sizeof(SCM))}. +@item +that the @code{LENGTH} field fits into 24 (or 56) bits on machines where +@code{size_t} is 32 bits or more. +@end itemize + +This is trickier than it first looks because the must_malloc() routine +is also used for allocating heap segments, which do not have the +@code{LENGTH} field restriction. Putting the 24 bit test into +@code{must_malloc()} should be tested for speed impact. +@end itemize + +@node Finishing Dynamic Linking, , Improvements To Make, The Implementation +@section Finishing Dynamic Linking + +@noindent +Scott Schwartz <schwartz@@galapagos.cse.psu.edu> suggests: One way to +tidy up the dynamic loading stuff would be to grab the code from perl5. + +@subsubheading VMS + +@noindent +George Carrette (gjc@@mitech.com) outlines how to dynamically link on +VMS. There is already some code in @file{dynl.c} to do this, but +someone with a VMS system needs to finish and debug it. + +@enumerate +@item +Say you have this @file{main.c} program: + +@format +@t{main() +@{init_lisp(); + lisp_repl();@}} +@end format + +@item +and you have your lisp in files @file{repl.c}, @file{gc.c}, +@code{eval.c} and there are some toplevel non-static variables in use +called @code{the_heap}, @code{the_environment}, and some read-only +toplevel structures, such as @code{the_subr_table}. + +@format +@t{$ LINK/SHARE=LISPRTL.EXE/DEBUG REPL.OBJ,GC.OBJ,EVAL.OBJ,LISPRTL.OPT/OPT} +@end format + +@item +where @file{LISPRTL.OPT} must contain at least this: + +@format +@t{SYS$LIBRARY:VAXCRTL/SHARE +UNIVERSAL=init_lisp +UNIVERSAL=lisp_repl +PSECT_ATTR=the_subr_table,SHR,NOWRT,LCL +PSECT_ATTR=the_heap,NOSHR,LCL +PSECT_ATTR=the_environment,NOSHR,LCL} +@end format + +@emph{Notice:} The @dfn{psect} (Program Section) attributes. +@table @code +@item LCL +means to keep the name local to the shared library. You almost always +want to do that for a good clean library. +@item SHR,NOWRT +means shared-read-only. Which is the default for code, and is also good +for efficiency of some data structures. +@item NOSHR,LCL +is what you want for everything else. +@end table + +Note: If you do not have a handy list of all these toplevel variables, +do not dispair. Just do your link with the /MAP=LISPRTL.MAP/FULL +and then search the map file, + +@format +@t{$SEARCH/OUT=LISPRTL.LOSERS LISPRTL.MAP ", SHR,NOEXE, RD, WRT"} +@end format + +And use an emacs keyboard macro to muck the result into the proper form. +Of course only the programmer can tell if things can be made read-only. +I have a DCL command procedure to do this if you want it. + +@item +@noindent +Now MAIN.EXE would be linked thusly: + +@format +@t{$ DEFINE LISPRTL USER$DISK:[JAFFER]LISPRTL.EXE + +$LINK MAIN.OBJ,SYS$INPUT:/OPT + SYS$LIBRARY:VAXCRTL/SHARE + LISPRTL/SHARE} +@end format + +Note the definition of the @code{LISPRTL} logical name. Without such a +definition you will need to copy @file{LISPRTL.EXE} over to +@file{SYS$SHARE:} (aka @file{SYS$LIBRARY:}) in order to invoke the main +program once it is linked. + +@item +Now say you have a file of optional subrs, @file{MYSUBRS.C}. And there +is a routine @code{INIT_MYSUBRS} that must be called before using it. + +@format +@t{$ CC MYSUBRS.C +$ LINK/SHARE=MYSUBRS.EXE MYSUBRS.OBJ,SYS$INPUT:/OPT + SYS$LIBRARY:VAXCRTL/SHARE + LISPRTL/SHARE + UNIVERSAL=INIT_MYSUBRS} +@end format + +Ok. Another hint is that you can avoid having to add the @code{PSECT} +declaration of @code{NOSHR,LCL} by declaring variables @code{status} in +the C language source. That works great for most things. + +@item +Then the dynamic loader would have to do this: + +@format +@t{@{void (*init_fcn)(); + long retval; + retval = lib$find_image_symbol("MYSUBRS","INIT_MYSUBRS",&init_fcn, + "SYS$DISK:[].EXE"); + if (retval != SS$_NORMAL) error(@dots{}); + (*init_fcn)();@}} +@end format + +But of course all string arguments must be @code{(struct dsc$descriptor +*)} and the last argument is optional if @code{MYSUBRS} is defined as a +logical name or if @file{MYSUBRS.EXE} has been copied over to +@file{SYS$SHARE}. The other consideration is that you will want to turn +off @key{C-c} or other interrupt handling while you are inside most +@code{lib$} calls. + +As far as the generation of all the @code{UNIVERSAL=@dots{}} +declarations. Well, you could do well to have that automatically +generated from the public @file{LISPRTL.H} file, of course. + +VMS has a good manual called the @cite{Guide to Writing Modular +Procedures} or something like that, which covers this whole area rather +well, and also talks about advanced techniques, such as a way to declare +a program section with a pointer to a procedure that will be +automatically invoked whenever any shared image is dynamically +activated. Also, how to set up a handler for normal or abnormal program +exit so that you can clean up side effects (such as opening a database). +But for use with @code{LISPRTL} you probably don't need that hair. + +One fancier option that is useful under VMS for @file{LISPLIB.EXE} is to +define all your exported procedures through an @dfn{call vector} instead +of having them just be pointers into random places in the image, which +is what you get by using @code{UNIVERSAL}. + +If you set up the call vector thing correctly it will allow you to +modify and relink @file{LISPLIB.EXE} without having to relink programs +that have been linked against it. +@end enumerate + +@subsubheading Windows NT +@noindent +George Carrette (gjc@@mitech.com) outlines how to dynamically link on +Windows NT: + +@itemize @bullet +@item +The Software Developers Kit has a sample called SIMPLDLL. +Here is the gist of it, following along the lines of the VMS description +above (contents of a makefile for the SDK NMAKE) + +@format +@t{LISPLIB.exp: +LISPLIB.lib: LISPLIB.def + $(implib) -machine:$(CPU) -def:LISPLIB.def -out:LISPLIB.lib + +LISPLIB.DLL : $(LISPLIB_OBJS) LISPLIB.EXP + $(link) $(linkdebug) \ + -dll \ + -out:LISPLIB.DLL \ + LISPLIB.EXP $(LISPLIB_OBJS) $(conlibsdll)} +@end format + +@item +The @file{LISPDEF.DEF} file has this: + +@format +@t{LIBRARY lisplib +EXPORT + init_lisp + init_repl} +@end format + +@item +And @file{MAIN.EXE} using: + +@format +@t{CLINK = $(link) $(ldebug) $(conflags) -out:$*.exe $** $(conlibsdll) + +MAIN.EXE : MAIN.OBJ LISPLIB.LIB + $(CLINK)} +@end format + +@item +And @file{MYSUBRS.DLL} is produced using: + +@format +@t{mysubrs.exp: +mysubrs.lib: mysubrs.def + $(implib) -machine:$(CPU) -def:MYSUBRS.def -out:MYSUBRS.lib + +mysubrs.dll : mysubrs.obj mysubrs.exp mysubrs.lib + $(link) $(linkdebug) \ + -dll \ + -out:mysubrs.dll \ + MYSUBRS.OBJ MYSUBRS.EXP LISPLIB.LIB $(conlibsdll)} +@end format + +@item +Where @file{MYSUBRS.DEF} has + +@format +@t{LIBRARY mysubrs +EXPORT + INIT_MYSUBRS} +@end format + +@item +And the dynamic loader looks something like this, calling the two +procedures @code{LoadLibrary} and @code{GetProcAddress}. + +@format +@t{LISP share_image_load(LISP fname) +@{long iflag; + LISP retval,(*fcn)(void); + HANDLE hLib; + DWORD err; + char *libname,fcnname[64]; + iflag = nointerrupt(1); + libname = c_string(fname); + _snprintf(fcnname,sizeof(fcnname),"INIT_%s",libname); + if (!(hLib = LoadLibrary(libname))) + @{err = GetLastError(); + retval = list2(fname,LSPNUM(err)); + serror1("library failed to load",retval);@} + if (!(fcn = (LISP (*)(void)) GetProcAddress(hLib,fcnname))) + @{err = GetLastError(); + retval = list2(fname,LSPNUM(err)); + serror1("could not find library init procedure",retval);@} + retval = (*fcn)(); + nointerrupt(iflag); + return(retval);@}} +@end format + +@item +@emph{Note:} in VMS the linker and dynamic loader is case sensitive, but +all the language compilers, including C, will by default upper-case +external symbols for use by the linker, although the debugger gets its +own symbols and case sensitivity is language mode dependant. In Windows +NT things are case sensitive generally except for file and device names, +which are case canonicalizing like in the Symbolics filesystem. + +@item +@emph{Also:} All this WINDOWS NT stuff will work in MS-DOS MS-Windows +3.1 too, by a method of compiling and linking under Windows NT, and then +copying various files over to MS-DOS/WINDOWS. +@end itemize + + +@node Procedure and Macro Index, Variable Index, The Implementation, Top +@unnumbered Procedure and Macro Index + +This is an alphabetical list of all the procedures and macros in SCM. + +@printindex fn + +@node Variable Index, Type Index, Procedure and Macro Index, Top +@unnumbered Variable Index + +This is an alphabetical list of all the global variables in SCM. + +@printindex vr + +@node Type Index, , Variable Index, Top +@unnumbered Type Index + +This is an alphabetical list of all the data types in SCM. + +@printindex tp + +@contents +@bye diff --git a/scm4e3.scmconfig.patch b/scm4e3.scmconfig.patch new file mode 100644 index 0000000..ff7dc48 --- /dev/null +++ b/scm4e3.scmconfig.patch @@ -0,0 +1,60 @@ +diff -c temp/scm/findexec.c temp/nscm/findexec.c +*** temp/scm/findexec.c Sun Mar 17 23:16:26 1996 +--- temp/nscm/findexec.c Thu Mar 21 08:51:27 1996 +*************** +*** 37,46 **** + filename. A new copy of the complete path name of that file is + returned. This new string may be disposed by free() later on. */ + + #include <sys/file.h> + #include <sys/param.h> +! #include <strings.h> +! #ifdef linux + # include <stdlib.h> + # include <sys/stat.h> + # include <unistd.h> /* for X_OK define */ +--- 37,47 ---- + filename. A new copy of the complete path name of that file is + returned. This new string may be disposed by free() later on. */ + ++ #include "scm.h" ++ + #include <sys/file.h> + #include <sys/param.h> +! #if defined(linux) || defined(__svr4__) + # include <stdlib.h> + # include <sys/stat.h> + # include <unistd.h> /* for X_OK define */ +*************** +*** 116,122 **** + if (*p) p++; + + if (name[0] == '.' && name[1] == 0) +! getwd(name); + + else if (name[0]=='~' && name[1]==0 && getenv("HOME")) + strcpy(name, getenv("HOME")); +--- 117,123 ---- + if (*p) p++; + + if (name[0] == '.' && name[1] == 0) +! getcwd(name, MAXPATHLEN); + + else if (name[0]=='~' && name[1]==0 && getenv("HOME")) + strcpy(name, getenv("HOME")); +diff -c temp/scm/scmfig.h temp/nscm/scmfig.h +*** temp/scm/scmfig.h Fri Sep 22 22:29:00 1995 +--- temp/nscm/scmfig.h Wed Mar 20 23:47:15 1996 +*************** +*** 50,55 **** +--- 50,59 ---- + # include <strings.h> + # endif + ++ # ifndef HAVE_GETCWD ++ # define getcwd(S,L) getwd(S) ++ # endif ++ + #else /* HAVE_CONFIG_H */ + + # ifdef sequent diff --git a/scmconfig.h.in b/scmconfig.h.in new file mode 100644 index 0000000..5fb6d27 --- /dev/null +++ b/scmconfig.h.in @@ -0,0 +1,69 @@ +/* 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 if on MINIX. */ +#undef _MINIX + +/* Define if your C compiler doesn't accept -c and -o together. */ +#undef NO_MINUS_C_MINUS_O + +/* 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 if you have ftime. */ +#undef HAVE_FTIME + +/* Define if you have getcwd. */ +#undef HAVE_GETCWD + +/* Define if you have times. */ +#undef HAVE_TIMES + +/* Define if you have the <limits.h> header file. */ +#undef HAVE_LIMITS_H + +/* Define if you have the <memory.h> header file. */ +#undef HAVE_MEMORY_H + +/* Define if you have the <string.h> header file. */ +#undef HAVE_STRING_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 <time.h> header file. */ +#undef HAVE_TIME_H + +/* Define if you have the <unistd.h> header file. */ +#undef HAVE_UNISTD_H diff --git a/scmfig.h b/scmfig.h new file mode 100644 index 0000000..ba95450 --- /dev/null +++ b/scmfig.h @@ -0,0 +1,671 @@ +/* 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. + */ + +/* "scmfig.h" system-dependent configuration. + Author: Aubrey Jaffer */ + +#ifdef HAVE_CONFIG_H +# include "scmconfig.h" +# ifdef HAVE_STRING_H +# include <string.h> +# else +# include <strings.h> +# endif + +# ifndef HAVE_GETCWD +# define getcwd(S,L) getwd(S) +# endif + +#else /* HAVE_CONFIG_H */ + +# ifdef sequent +# include <strings.h> +# define strchr index +# define strrchr rindex +# else +# include <string.h> +# endif + +# include "scmflags.h" /* user specified, system independent flags */ + +/* IMPLINIT is the full pathname (surrounded by double quotes) of + Init.scm, the Scheme initialization code. This is best defined in + the makefile, if possible. If available, scm uses the value of + environment variable SCM_INIT_PATH instead of IMPLINIT. */ + +/* #define IMPLINIT "/usr/jaffer/scm/Init.scm" */ + +/* INITS is calls to initialization routines for any compiled + libraries being linked into scm. This is best done in the makefile. +File: INITS line: functions defined: + +sc2.c init_sc2(); substring-move-left!, substring-move-right!, + substring-fill!, append!, and last-pair +rgx.c init_rgx(); regcomp and regexec. */ + +/* #define INITS init_sc2(); */ + +/* #define SICP */ + +/* setbuf(0) needs to be done for tty ports in order for CHAR-READY? + to work. This can cause problems under MSDOS and other systems. */ + +/* #define NOSETBUF */ + +/* #define RECKLESS */ + +/* #define CAUTIOUS */ + +/* #define STACK_LIMIT (HEAP_SEG_SIZE/2) */ + +/* #define BIGNUMS */ + +/* #define ARRAYS */ + +/* #define FLOATS */ + +/* Define SINGLES if you want single precision floats and + (sizeof(float)==sizeof(long)) */ + +# ifdef FLOATS +# define SINGLES +# endif + +/* #define SINGLESONLY */ + +/* Define CDR_DOUBLES if (sizeof(double)==sizeof(long)), i.e. + a `single' is really a double. */ +# ifdef FLOATS +# ifdef __alpha +# define CDR_DOUBLES +# endif + +# ifdef _UNICOS /* doubles are no better than singles on Cray. */ +# define SINGLESONLY +# endif + +# ifdef CDR_DOUBLES +# define SINGLES +# define SINGLESONLY +# endif +# endif + +/* #define ENGNOT */ + +/* Define SUN_DL to configure code in "dynl.c" so that dynamic linking + is done using the SUN dynamic linking library "dl". */ + +/* #define SUN_DL */ + +/* Define DLD to configure code in "dynl.c" so that dynamic linking is + done using the "dld" library. DLD is ported to Linux, VAX + (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation (SunOS 4.0), + Sequent Symmetry (Dynix), and Atari ST. See scm/README or + scm/ANNOUNCE for ftp sites offering dld. */ + +/* #define DLD */ + +/* Define HAVE_DYNL if dynamic linking is available */ + +# ifdef DLD +# define HAVE_DYNL +# endif +# ifdef SUN_DL +# define HAVE_DYNL +# endif +# ifdef HP_SHL +# define HAVE_DYNL +# endif + +# ifdef HAVE_DYNL +# define CCLO +# endif + +/* Define GC_FREE_SEGMENTS if you want segments of unused heap to + be freed up after garbage collection. Don't define it if you + never want the heap to shrink. */ + +# ifndef DONT_GC_FREE_SEGMENTS +# define GC_FREE_SEGMENTS +# endif + +/* MEMOIZE_LOCALS will speed up most local variable references. You + will need to remove this and recompile eval.c if you use very large or + deep environments (more than 4095 bound variables in one procedure)*/ + +# define MEMOIZE_LOCALS + +/* #define CHEAP_CONTINUATIONS */ + +/* #define TICKS */ + +/* PROT386 should be defined on the compilation command line if the + program is to be run on an intel 386 in protected mode. `Huge' + pointers common on MSDOS compilers do not work in protected mode. + PROT386 is required if scm is to run as part of a Microsoft Windows + application. Added by Stephen Adams 8 May 92 */ + +/* #define PROT386 */ + +/* #define NON_PREEMPTIVE and RTL if you are using an non-preemptive + operating system in which periodic polling for interrupts is + necessary. Provide your own main procedure (e.g., WinMain, in + Windows). Define and initialize unsigned int poll_count, and + provide a procedure named poll_routine(), which POLL calls each + time poll_count reaches zero. poll_routine() must reinitialize + poll_count. It may also check for external actions, such as + Windows messages. The value assigned to poll_count can be quite + large, e.g., 1000, while still maintaining good response time. */ + +/* #define CAREFUL_INTS */ + +/* STDC_HEADERS indicates that the include file names are the same as + ANSI C. For most modern systems this is the case. */ + +/* added by Yasuaki Honda */ +# ifdef THINK_C +# define __STDC__ +# endif + +# ifdef __STDC__ +# ifndef __HIGHC__ /* overly fussy compiler */ +# define USE_ANSI_PROTOTYPES +# endif +# ifndef __GNUC__ +# define STDC_HEADERS +# else +# ifdef sparc +# ifdef SVR4 +# define STDC_HEADERS +# endif +# else +# ifndef tahoe +# ifndef sun +# define STDC_HEADERS +# endif +# endif +# endif +# endif +# endif +# ifdef MSDOS /* Microsoft C 5.10 and 6.00A */ +# ifndef GO32 +# define SHORT_INT +# endif +# endif +# ifdef _QC +# define SHORT_INT +# endif +# ifdef __TURBOC__ +# define SHORT_INT +# ifndef __TOS__ +# define MSDOS +# endif +# endif +# ifdef _WIN32 +# define MSDOS +# define LACK_TIMES +# endif +# ifdef _MSDOS +# define MSDOS +# endif +# ifdef MSDOS +# define STDC_HEADERS +# endif +# ifdef vms +# define STDC_HEADERS +# endif +# ifdef nosve +# define STDC_HEADERS +# endif + +# ifdef linux +# define HAVE_SELECT +# define HAVE_SYS_TIME_H +# undef STDC_HEADERS +# endif + +# ifdef _UNICOS +# define STDC_HEADERS +# endif + +# ifdef _AIX +# define _POSIX_SOURCE +# define LACK_FTIME +# endif + +# ifdef __sgi__ +# define LACK_FTIME +# define STDC_HEADERS +# define USE_ANSI_PROTOTYPES +# define HAVE_SELECT +# define HAVE_SYS_TIME_H +# define __svr4__ +# endif + +# ifdef hpux +# define LACK_E_IDs +# endif + +/* C-Set++ for OS/2 */ +# ifdef __IBMC__ +# define STDC_HEADERS +# define LACK_TIMES +# endif + +#endif /* HAVE_CONFIG_H */ + +/* PROMPT is the prompt string printed at top level */ + +#ifndef PROMPT +# ifdef SICP +# define PROMPT "==> " +# else +# define PROMPT "> " +# endif +#endif + +/* #define BRACKETS_AS_PARENS to have [ and ] be read as ( and ) in forms. */ + +/* #define BRACKETS_AS_PARENS */ + +/* 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. + + WHITE_SPACES are other characters which should be treated like spaces + in programs. in both cases sparate characters with ":case " */ + +#define LINE_INCREMENTORS '\n' +#ifdef MSDOS +# define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26 +#else +# define WHITE_SPACES ' ':case '\t':case '\r':case '\f' +#endif + +/* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */ + +#define NUM_HASH_BUCKETS 137 + +/* 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 (heap_size/4) + +/* Define BIGDIG to an integer type whose size is smaller than long if + you want bignums. BIGRAD is one greater than the biggest BIGDIG. */ +/* Define DIGSTOOBIG if the digits equivalent to a long won't fit in a long. */ +#ifdef BIGNUMS +# ifdef _UNICOS +# define DIGSTOOBIG +# if (1L << 31) <= USHRT_MAX +# define BIGDIG unsigned short +# else +# define BIGDIG unsigned int +# endif +# define BITSPERDIG 32 +# else +# define BIGDIG unsigned short +# define BITSPERDIG (sizeof(BIGDIG)*CHAR_BIT) +# endif +# define BIGRAD (1L << BITSPERDIG) +# define DIGSPERLONG ((sizet)((sizeof(long)*CHAR_BIT+BITSPERDIG-1)/BITSPERDIG)) +# define BIGUP(x) ((unsigned long)(x) << BITSPERDIG) +# define BIGDN(x) ((x) >> BITSPERDIG) +# define BIGLO(x) ((x) & (BIGRAD-1)) +#endif + +#ifndef BIGDIG +# ifndef FLOATS +# define INUMS_ONLY +# endif +#endif + +#ifdef NON_PREEMPTIVE +# define DEFER_INTS /**/ +# ifdef TICKS +# define POLL {if (0==poll_count--) poll_routine(); \ + if (0==tick_count--) tick_signal();} +# else +# define POLL {if (0==poll_count--) poll_routine();} +# endif +# define CHECK_INTS POLL +# define ALLOW_INTS POLL +#else +# ifdef CAREFUL_INTS +# define DEFER_INTS {if (ints_disabled) \ + fputs("ints already disabled\n", stderr); \ + ints_disabled = 1;} +# define ALLOW_INTS {if (!ints_disabled) \ + fputs("ints already enabled\n", stderr); \ + ints_disabled = 0;CHECK_INTS} +# else +# define DEFER_INTS {ints_disabled = 1;} +# define ALLOW_INTS {ints_disabled = 0;CHECK_INTS} +# endif +# ifdef TICKS +# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();\ + POLL;} +# define POLL {if (0==tick_count--) tick_signal();} +# else +# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();} +# define POLL /**/ +# endif +#endif + +#ifdef STACK_LIMIT +# define CHECK_STACK {stack_check();} +#else +# define CHECK_STACK /**/ +#endif + +/* 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 cell, pointers + to vector elts, functions, &c are not munged. */ +#ifdef _UNICOS +# define SCM2PTR(x) ((int)(x) >> 3) +# define PTR2SCM(x) (((SCM)(x)) << 3) +# define POINTERS_MUNGED +#else +# define SCM2PTR(x) (x) +# define PTR2SCM(x) ((SCM)(x)) +#endif + +/* FIXABLE is non-null if its long argument can be encoded in an INUM. */ + +#define POSFIXABLE(n) ((n) <= MOST_POSITIVE_FIXNUM) +#define NEGFIXABLE(n) ((n) >= MOST_NEGATIVE_FIXNUM) +#define UNEGFIXABLE(n) ((n) <= -MOST_NEGATIVE_FIXNUM) +#define FIXABLE(n) (POSFIXABLE(n) && NEGFIXABLE(n)) + +/* The following 8 definitions are defined automatically by the C + pre-processor. You will need to override these if you are + cross-compiling or if the C pre-processor has different properties + than the compiler. */ + +#if (((-1)%2==-1) && ((-1)%(-2)==-1) && (1%2==1) && (1%(-2)==1)) +#else +# define BADIVSGNS +#endif + +/* 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 SRS(x, y) ((x)>>y) +# ifdef __TURBOC__ +# define INUM(x) (((x)>>1)>>1) +# else +# define INUM(x) SRS(x, 2) +# endif +#else +# define SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y) +# define INUM(x) SRS(x, 2) +#endif + +#ifdef __TURBOC__ +/* shifts of more than one are done by a library call, single shifts are + performed in registers */ +# define MAKINUM(x) ((((x)<<1)<<1)+2L) +#else +# define MAKINUM(x) (((x)<<2)+2L) +#endif + +#ifdef _DCC +# define ASCII +#else +# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) +# define EBCDIC +# endif +# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) +# define ASCII +# endif +#endif + +/* CHAR_CODE_LIMIT is the number of distinct characters represented by + the unsigned char datatype. */ +/* MOST_POSITIVE_FIXNUM is the INUM closest to positive infinity. */ +/* MOST_NEGATIVE_FIXNUM is the INUM closest to negative infinity. */ + +#ifdef __STDC__ +# define HAVE_LIMITSH +#endif +#ifdef MWC +# define HAVE_LIMITSH +#endif + +#ifdef HAVE_LIMITSH +# include <limits.h> +# ifdef UCHAR_MAX +# define CHAR_CODE_LIMIT (UCHAR_MAX+1L) +# else +# define CHAR_CODE_LIMIT 256L +# endif +# define MOST_POSITIVE_FIXNUM (LONG_MAX>>2) +# ifdef _UNICOS /* Stupid cray bug */ +# define MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4) +# else +# define MOST_NEGATIVE_FIXNUM SRS((long)LONG_MIN, 2) +# endif /* UNICOS */ +#else +# define CHAR_CODE_LIMIT 256L +# define MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3)) +# if (0 != ~0) +# define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM-1) +# else +# define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM) +# endif +#endif + +/* INTBUFLEN is the maximum number of characters neccessary for the + printed or string representation of an exact number. */ + +#ifndef CHAR_BIT +# define CHAR_BIT 8 +#endif +#ifndef LONG_BIT +# define LONG_BIT (CHAR_BIT*sizeof(long)/sizeof(char)) +#endif +#define INTBUFLEN (5+LONG_BIT) + +/* FLOBUFLEN is the maximum number of characters neccessary for the + printed or string representation of an inexact number. */ + +#ifdef FLOATS +# define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*CHAR_BIT*3+9)/10) +#endif /* FLOATS */ + +/* MAXEXP is the maximum double precision expontent */ +/* FLTMAX is less than or equal the largest single precision float */ + +#ifdef FLOATS +# ifdef STDC_HEADERS +# ifndef GO32 +# include <float.h> +# endif +# endif +# ifdef DBL_MAX_10_EXP +# define MAXEXP DBL_MAX_10_EXP +# else +# define MAXEXP 308 /* IEEE doubles */ +# endif +# ifdef FLT_MAX +# define FLTMAX FLT_MAX +# else +# define FLTMAX 1e+23 +# endif +#endif + +/* Only some machines have pipes */ +#ifdef _IBMR2 +# define unix +# define STDC_HEADERS +#endif +#ifdef unix + /* DJGPP (gcc for i386) defines unix! */ +# ifndef GO32 +# define HAVE_PIPE +# endif +#endif + +/* IS_INF tests its floating point number for infiniteness */ + +#ifndef IS_INF +# define IS_INF(x) ((x)==(x)/2) +#endif + +#ifndef THINK_C +# ifdef __WINDOWS__ /* there should be a better flag for this. */ +# define PROT386 +# endif +#endif + +/* PTR_LT defines how to compare two CELLPTRs (which may not be in the + same array). 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__) +# ifdef PROT386 +typedef cell *CELLPTR; +typedef SCM *SCMPTR; +# define PTR_LT(x, y) (((long)(x)) < ((long)(y))) +# else +typedef cell huge *CELLPTR; +typedef SCM huge *SCMPTR; +# define PTR_LT(x, y) ((x) < (y)) +# endif +#else /* not __TURBOC__ */ +typedef cell *CELLPTR; +typedef SCM *SCMPTR; +# ifdef nosve +# define PTR_MASK 0xffffffffffff +# define PTR_LT(x, y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK)) +# else +# define PTR_LT(x, y) ((x) < (y)) +# endif +#endif + +#ifdef STDC_HEADERS +# include <stdlib.h> +# ifdef AMIGA +# include <stddef.h> +# endif +# define sizet size_t +#else +# ifdef _SIZE_T +# define sizet size_t +# else +# define sizet unsigned int +# endif +#endif + +/* On VMS, GNU C's errno.h contains a special hack to get link attributes + for errno correct for linking to the C RTL. */ + +#include <errno.h> + +/* SYSCALL retries system calls that have been interrupted (EINTR) */ +#ifdef vms +# ifndef __GNUC__ +# include <ssdef.h> +# define SYSCALL(line) do{errno = 0;line} \ + while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) +# endif +#endif + +#ifndef SYSCALL +# ifdef EINTR +# if (EINTR > 0) +# define SYSCALL(line) do{errno = 0;line}while(EINTR==errno) +# endif +# endif +#endif + +#ifndef SYSCALL +# define SYSCALL(line) {line} +#endif + +#ifndef MSDOS +# ifdef ARM_ULIB + extern volatile int errno; +# else + extern int errno; +# endif +#endif +#ifdef __TURBOC__ +# if (__TURBOC__==1) + /* Needed for TURBOC V1.0 */ + extern int errno; +# endif +#endif + +/* EXIT_SUCCESS is the default code to return from SCM if no errors + were encountered. 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 (quit <n>). */ + +#ifndef EXIT_SUCCESS +# ifdef vms +# define EXIT_SUCCESS 1 +# else +# define EXIT_SUCCESS 0 +# endif +#endif +#ifndef EXIT_FAILURE +# ifdef vms +# define EXIT_FAILURE 2 +# else +# define EXIT_FAILURE 1 +# endif +#endif + +/* Yasuaki Honda */ +/* Think C lacks isascii macro */ +#ifdef THINK_C +# define isascii(c) ((unsigned)(c) <= 0x7f) +#endif +#ifdef _DCC +# define isascii(c) ((unsigned)(c) <= 0x7f) +#endif + +/* end of automatic C pre-processor definitions */ diff --git a/setjump.h b/setjump.h new file mode 100644 index 0000000..eb7e90b --- /dev/null +++ b/setjump.h @@ -0,0 +1,122 @@ +/* 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. + */ + +/* "setjump.h" memory and stack parameters. + Author: Aubrey Jaffer */ + +/* CELL_UP and CELL_DN are used by init_heap_seg to find 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) (CELLPTR)(~1L & ((long)(p)+1L)) +#define CELL_DN(p) (CELLPTR)(~1L & (long)(p)) +#else +#define CELL_UP(p) (CELLPTR)(~(sizeof(cell)-1L) & ((long)(p)+sizeof(cell)-1L)) +#define CELL_DN(p) (CELLPTR)(~(sizeof(cell)-1L) & (long)(p)) +#endif /* UNICOS */ +#endif /* PROT386 */ + +/* These are parameters for controlling memory allocation. The heap + is the area out of which cons and object headers is allocated. + Each heap object is 8 bytes on a 32 bit machine and 16 bytes on a + 64 bit machine. The units of the _SIZE parameters are bytes. + + 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 INIT_HEAP_SIZE heap cannot be allocated initially, HEAP_SEG_SIZE + will be used, and the heap will grow by HEAP_SEG_SIZE when more + heap is needed. HEAP_SEG_SIZE must fit into type sizet. This code + is in init_storage() and alloc_some_heap() in sys.c + + If INIT_HEAP_SIZE can be allocated initially, the heap will grow by + EXPHEAP(heap_size) when more heap is needed. + + 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. */ + +#define INIT_HEAP_SIZE (25000L*sizeof(cell)) +#define MIN_HEAP_SEG_SIZE (2000L*sizeof(cell)) +#ifdef _QC +#define HEAP_SEG_SIZE 32400L +#else +#ifdef sequent +#define HEAP_SEG_SIZE (7000L*sizeof(cell)) +#else +#define HEAP_SEG_SIZE (8100L*sizeof(cell)) +#endif +#endif +#define EXPHEAP(heap_size) (heap_size*2) +#define INIT_MALLOC_LIMIT 100000 + +#ifdef IN_CONTINUE_C +# include "scm.h" +# define malloc(size) must_malloc((long)(size), s_cont) +# define free(obj) must_free((char *)(obj)) +#endif + +/* other.dynenv and other.parent get GCed just by being there. */ +struct scm_other {SCM dynenv; + SCM parent; +#ifdef CAUTIOUS + SCM stack_trace; +#endif + }; +#define CONTINUATION_OTHER struct scm_other +#define CONT(x) ((CONTINUATION *)CDR(x)) +#define SETCONT SETCDR +void dowinds P((SCM to, long delta)); + +#include "continue.h" + +/* See scm.h for definition of P */ +void mark_locations P((STACKITEM x [], sizet n )); +void scm_dynthrow P((CONTINUATION *cont, SCM val)); +#define s_cont (ISYMCHARS(IM_CONT)+20) diff --git a/setjump.mar b/setjump.mar new file mode 100644 index 0000000..2b49243 --- /dev/null +++ b/setjump.mar @@ -0,0 +1,38 @@ + .title setjump and longjump +; The VAX C runtime library uses the $unwind utility for implementing +; longjmp. That fails if your program do not follow normal +; stack decipline. This is a dirty implementation of setjmp +; and longjmp that does not have that problem. +; the names longjmp and setjmp are avoided so that the code can be linked +; with the vax c runtime library without name clashes. + +; This code was contributed by an anonymous reviewer from +; comp.sources.reviewed. + + .entry setjump,^M<IV> + movl 4(ap),r0 + movq r2,(r0)+ + movq r4,(r0)+ + movq r6,(r0)+ + movq r8,(r0)+ + movq r10,(r0)+ + movl fp,(r0)+ + movo 4(fp),(r0)+ + movq 20(fp),(r0) + clrl r0 + ret + + .entry longjump,^M<IV> + movl 4(ap),r0 + movq (r0)+,r2 + movq (r0)+,r4 + movq (r0)+,r6 + movq (r0)+,r8 + movq (r0)+,r10 + movl (r0)+,r1 + movo (r0)+,4(r1) + movq (r0),20(r1) + movl 8(ap),r0 + movl r1,fp + ret + .end diff --git a/setjump.s b/setjump.s new file mode 100644 index 0000000..b96fb05 --- /dev/null +++ b/setjump.s @@ -0,0 +1,40 @@ +* setjmp on the Cray YMP does not save all registers. Although this +* conforms to the ANSI standard, it is not sufficient for SCM garbage +* collection and continuations. +* +* This is a version of setjump for the Cray YMP that does save all non- +* temporary registers. It might work for the XMP. It definitely will +* not work on the Cray 2. I do not know if the setjmp on the Cray 2 will +* work with SCM or not. +* +* This has been tested under Unicos 6.1. +* +* --Radey Shouman <rshouman@chpc.utexas.edu> +* + IDENT SETJUMP + ENTRY setjump +setjump = * + A1 1,A6 + A2 56 + A0 A1 + ,A0 T00,A2 + A0 A1+A2 + ,A0 B00,A2 + S1 0 + J B00 +* + ENTRY longjump +longjump = * + A1 1,A6 + A0 A1 + A2 56 + T00,A2 ,A0 + A0 A1+A2 + B00,A2 ,A0 + S1 2,A6 + J B00 + END +** Local Variables: +** tab-stop-list: (12 28 45) +** indent-tabs-mode: nil +** End: diff --git a/socket.c b/socket.c new file mode 100644 index 0000000..4446253 --- /dev/null +++ b/socket.c @@ -0,0 +1,635 @@ +/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "socket.c" internet stream socket support for client/server in SCM + Author: Aubrey Jaffer. + Thanks to Hallvard.Tretteberg@si.sintef.no + who credits NCSA httpd software by Rob McCool 3/21/93 +*/ + +#include "scm.h" +#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 P((int fd)); +#endif /* STDC_HEADERS */ + +static char s_inetaddr[] = "inet:string->address"; +SCM l_inetaddr (host) + SCM host; +{ + struct in_addr soka; + ASSERT(NIMP(host) && STRINGP(host), host, ARG1, s_inetaddr); + soka.s_addr = inet_addr(CHARS(host)); + if (-1==soka.s_addr) { + struct hostent *entry; + DEFER_INTS; + SYSCALL(entry = gethostbyname(CHARS(host));); + ALLOW_INTS; + if (!entry) return BOOL_F; + return ulong2num(ntohl(((struct in_addr *)entry->h_addr)->s_addr)); + } + return ulong2num(ntohl(soka.s_addr)); +} + +static char s_inetstr[] = "inet:address->string"; +SCM l_inetstr (inetid) + SCM inetid; +{ + struct in_addr addr; + char *ans; + addr.s_addr = htonl(num2ulong(inetid, (char *)ARG1, s_inetstr)); + SYSCALL(ans = inet_ntoa(addr);); + return makfrom0str(ans); +} + +static char s_network[] = "inet:network"; +SCM l_network (host) + SCM host; +{ + struct in_addr addr; + addr.s_addr = htonl(num2ulong(host, (char *)ARG1, s_network)); + return ulong2num(0L+inet_netof(addr)); +} + +static char s_lna[] = "inet:local-network-address"; +SCM l_lna (host) + SCM host; +{ + struct in_addr addr; + addr.s_addr = htonl(num2ulong(host, (char *)ARG1, s_lna)); + return ulong2num(0L+inet_lnaof(addr)); +} + +static char s_makaddr[] = "inet:make-address"; +SCM l_makaddr (net, lna) + SCM net, lna; +{ + struct in_addr addr; + unsigned long netnum = num2ulong(net, (char *)ARG1, s_makaddr); + unsigned long lnanum = num2ulong(lna, (char *)ARG2, s_makaddr); + addr = inet_makeaddr(netnum, lnanum); + return ulong2num(ntohl(addr.s_addr)); +} + +static char s_hostinfo[] = "gethost"; +SCM l_hostinfo(name) + SCM name; +{ + SCM ans = make_vector(MAKINUM(5), UNSPECIFIED); + SCM *ve = VELTS(ans); + SCM lst = EOL; + struct hostent *entry; + struct in_addr inad; + char **argv; + int i = 0; +#ifndef linux + if UNBNDP(name) { + DEFER_INTS; + SYSCALL(entry = gethostent();); + } + else +#endif + if (NIMP(name) && STRINGP(name)) { + DEFER_INTS; + SYSCALL(entry = gethostbyname(CHARS(name));); + } + else { + inad.s_addr = htonl(num2ulong(name, (char *)ARG1, s_hostinfo)); + DEFER_INTS; + SYSCALL(entry = gethostbyaddr((char *)&inad , sizeof(inad), AF_INET);); + } + ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->h_name); + ve[ 1] = makfromstrs(-1, entry->h_aliases); + ve[ 2] = MAKINUM(entry->h_addrtype + 0L); + ve[ 3] = MAKINUM(entry->h_length + 0L); + if (sizeof(struct in_addr) != entry->h_length) + {ve[ 4] = BOOL_F; return ans;} + for(argv = entry->h_addr_list; argv[i]; i++); + while (i--) { + inad = *(struct in_addr *)argv[i]; + lst = cons(ulong2num(ntohl(inad.s_addr)), lst); + } + ve[ 4] = lst; + return ans; +} +static char s_netinfo[] = "getnet"; +SCM l_netinfo(name) + SCM name; +{ + SCM ans = make_vector(MAKINUM(4), UNSPECIFIED); + SCM *ve = VELTS(ans); + struct netent *entry; + if UNBNDP(name) { + DEFER_INTS; + SYSCALL(entry = getnetent();); + } + else if (NIMP(name) && STRINGP(name)) { + DEFER_INTS; + SYSCALL(entry = getnetbyname(CHARS(name));); + } + else { + unsigned long netnum; + netnum = num2ulong(name, (char *)ARG1, s_netinfo); + DEFER_INTS; + SYSCALL(entry = getnetbyaddr(netnum, AF_INET);); + } + ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->n_name); + ve[ 1] = makfromstrs(-1, entry->n_aliases); + ve[ 2] = MAKINUM(entry->n_addrtype + 0L); + ve[ 3] = ulong2num(entry->n_net + 0L); + return ans; +} +static char s_protoinfo[] = "getproto"; +SCM l_protoinfo(name) + SCM name; +{ + SCM ans = make_vector(MAKINUM(3), UNSPECIFIED); + SCM *ve = VELTS(ans); + struct protoent *entry; + if UNBNDP(name) { + DEFER_INTS; + SYSCALL(entry = getprotoent();); + } + else if (NIMP(name) && STRINGP(name)) { + DEFER_INTS; + SYSCALL(entry = getprotobyname(CHARS(name));); + } + else { + unsigned long protonum; + protonum = num2ulong(name, (char *)ARG1, s_protoinfo); + DEFER_INTS; + SYSCALL(entry = getprotobynumber(protonum);); + } + ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->p_name); + ve[ 1] = makfromstrs(-1, entry->p_aliases); + ve[ 2] = MAKINUM(entry->p_proto + 0L); + return ans; +} +static char s_servinfo[] = "getserv"; +SCM l_servinfo(args) + SCM args; +{ + SCM ans = make_vector(MAKINUM(4), UNSPECIFIED); + SCM *ve = VELTS(ans); + SCM name, proto; + struct servent *entry; + if NULLP(args) { + DEFER_INTS; + SYSCALL(entry = getservent();); + goto comlab; + } + name = CAR(args); + proto = CDR(args); + ASSERT(NIMP(proto) && CONSP(proto), args, WNA, s_servinfo); + proto = CAR(proto); + ASSERT(NIMP(proto) && STRINGP(proto), args, ARG2, s_servinfo); + DEFER_INTS; + if (NIMP(name) && STRINGP(name)) + SYSCALL(entry = getservbyname(CHARS(name), CHARS(proto));); + else { + ASSERT(INUMP(proto), proto, ARG1, s_servinfo); + SYSCALL(entry = getservbyport(INUM(proto), CHARS(proto));); + } + comlab: ALLOW_INTS; + if (!entry) return BOOL_F; + ve[ 0] = makfrom0str(entry->s_name); + ve[ 1] = makfromstrs(-1, entry->s_aliases); + ve[ 2] = MAKINUM(ntohs(entry->s_port) + 0L); + ve[ 3] = makfrom0str(entry->s_proto); + return ans; +} + +SCM l_sethost(arg) + SCM arg; +{ + if UNBNDP(arg) endhostent(); + else sethostent(NFALSEP(arg)); + return UNSPECIFIED; +} +SCM l_setnet(arg) + SCM arg; +{ + if UNBNDP(arg) endnetent(); + else setnetent(NFALSEP(arg)); + return UNSPECIFIED; +} +SCM l_setproto(arg) + SCM arg; +{ + if UNBNDP(arg) endprotoent(); + else setprotoent(NFALSEP(arg)); + return UNSPECIFIED; +} +SCM l_setserv(arg) + SCM arg; +{ + if UNBNDP(arg) endservent(); + else setservent(NFALSEP(arg)); + return UNSPECIFIED; +} + +static char s_socket[] = "make-stream-socket"; +SCM l_socket(fam, proto) + SCM fam, proto; +{ + int sd, j, tp = INUM(fam); + FILE* f; + SCM port; + ASSERT(INUMP(fam), fam, ARG1, s_socket); + if UNBNDP(proto) proto = INUM0; + else ASSERT(INUMP(proto), proto, ARG2, s_socket); + NEWCELL(port); + DEFER_INTS; + SYSCALL(sd = socket(tp, SOCK_STREAM, INUM(proto));); + if (-1==sd) wta(UNDEFINED, (char *)NALLOC, s_socket); + SYSCALL(f = fdopen(sd, "r+");); + if (!f) { + close(sd); + wta(MAKINUM(sd), (char *)NALLOC, s_port_type); + } + CAR(port) = tc_socket | (tp<<24) | BUF0; + SETSTREAM(port, f); + i_setbuf0(port); + ALLOW_INTS; + if (AF_INET==tp) { + sd = setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &j, sizeof(j)); + ASSERT(!sd, port, "could not set socket option", s_socket); + } + return port; +} +static char s_socketpair[] = "make-stream-socketpair"; +SCM l_socketpair(fam, proto) + SCM fam, proto; +{ + int sts, tp = INUM(fam); + int sv[2]; + FILE* f[2]; + SCM port[2]; + ASSERT(INUMP(fam), fam, ARG1, s_socketpair); + if UNBNDP(proto) proto = INUM0; + else ASSERT(INUMP(proto), proto, ARG2, s_socketpair); + NEWCELL(port[0]); NEWCELL(port[1]); + DEFER_INTS; + SYSCALL(sts = socketpair(tp, SOCK_STREAM, INUM(proto), sv);); + if (-1==sts) wta(UNDEFINED, (char *)NALLOC, s_socketpair); + SYSCALL(f[0] = fdopen(sv[0], "r+");); + if (!f[0]) { + close(sv[0]); + wta(MAKINUM(sv[0]), (char *)NALLOC, s_port_type); + } + SYSCALL(f[1] = fdopen(sv[1], "r+");); + if (!f[1]) { + fclose(f[0]); + close(sv[1]); + wta(MAKINUM(sv[1]), (char *)NALLOC, s_port_type); + } + CAR(port[0]) = CAR(port[1]) = tc16_fport | mode_bits("r+0"); + SETSTREAM(port[0], f[0]); SETSTREAM(port[1], f[1]); + i_setbuf0(port[0]); i_setbuf0(port[1]); + ALLOW_INTS; + return cons(port[0], port[1]); +} + +static char s_shutdown[] = "socket:shutdown"; +SCM l_shutdown(port, how) + SCM port, how; +{ + int sts; + ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_shutdown); + ASSERT(INUMP(how) && 0 <= INUM(how) && 2 >= INUM(how), + how, ARG2, s_shutdown); + SYSCALL(sts = shutdown(fileno(STREAM(port)), INUM(how));); + if (sts) return BOOL_F; + switch (INUM(how)) { + case 0: CAR(port) &= ~RDNG; + break; + case 1: CAR(port) &= ~WRTNG; + break; + case 2: CAR(port) &= ~(RDNG | WRTNG); + } + if SOCKP(port) close_port(port); /* can't read or write */ + return port; +} +static char s_unkfam[] = "unknown-family"; +static char s_connect[] = "socket:connect"; +SCM l_connect (sockpt, address, arg) + SCM sockpt, address, arg; +{ + int sts; + ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect); + switch SOCKTYP(sockpt) { + default: + ASSERT(0, sockpt, s_unkfam, s_connect); + case AF_INET: + ASSERT(NIMP(arg) && CONSP(arg) && NULLP(CDR(arg)), arg, WNA, s_connect); + arg = CAR(arg); + ASSERT(INUMP(arg), arg, ARG3, s_connect); + { + struct sockaddr_in soka; + soka.sin_addr.s_addr = + htonl(num2ulong(address, (char *)ARG2, s_connect)); + soka.sin_family = AF_INET; + soka.sin_port = htons(INUM(arg)); + SYSCALL(sts = connect(fileno(STREAM(sockpt)), + (struct sockaddr*)&soka, sizeof(soka));); + } + break; + case AF_UNIX: + ASSERT(NULLP(arg), arg, WNA, s_connect); + ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_connect); + { + struct sockaddr_un soka; + soka.sun_family = AF_UNIX; + memcpy(&soka.sun_path, CHARS(address), 1+LENGTH(address)); + SYSCALL(sts = connect(fileno(STREAM(sockpt)), + (struct sockaddr*)&soka, sizeof(soka));); + } + break; + } + if (sts) return BOOL_F; + CAR(sockpt) = tc16_fport | mode_bits("r+0"); + return sockpt; +} + +static char s_bind[] = "socket:bind"; +SCM l_bind(sockpt, address) + SCM sockpt, address; +{ + int sts; + ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_bind); + switch SOCKTYP(sockpt) { + default: + ASSERT(0, sockpt, s_unkfam, s_bind); + case AF_UNIX: + ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_bind); + { + struct sockaddr_un sa_server; + bzero((char *) &sa_server, sizeof(sa_server)); + sa_server.sun_family = AF_UNIX; + memcpy(&sa_server.sun_path, CHARS(address), 1+LENGTH(address)); + SYSCALL(sts = bind(fileno(STREAM(sockpt)), + (struct sockaddr *)&sa_server, sizeof(sa_server));); + } + break; + case AF_INET: + ASSERT(INUMP(address), address, ARG2, s_bind); + { + struct sockaddr_in sa_server; + bzero((char *) &sa_server, sizeof(sa_server)); + sa_server.sin_family = AF_INET; + sa_server.sin_addr.s_addr = htonl(INADDR_ANY); + sa_server.sin_port = htons(INUM(address)); + SYSCALL(sts = bind(fileno(STREAM(sockpt)), + (struct sockaddr *)&sa_server, sizeof(sa_server));); + } + break; + } + return sts ? BOOL_F : sockpt; +} + +static char s_listen[] = "socket:listen"; +SCM l_listen(port, backlog) + SCM port, backlog; +{ + int sts; + ASSERT(NIMP(port) && SOCKP(port), port, ARG1, s_listen); + ASSERT(INUMP(backlog), backlog, ARG2, s_listen); + SYSCALL(sts = listen(fileno(STREAM(port)), INUM(backlog));); + if (sts) return BOOL_F; + CAR(port) = tc16_fport | mode_bits("r0"); + return port; +} + +static char s_accept[] = "socket:accept"; +SCM l_accept(sockpt) + SCM sockpt; +{ + int newsd, sadlen; + struct sockaddr sad; + FILE *newfd; + SCM newpt; + NEWCELL(newpt); + ASSERT(NIMP(sockpt) && OPINPORTP(sockpt), sockpt, ARG1, s_accept); + sadlen=sizeof(sad); + DEFER_INTS; + SYSCALL(newsd = accept(fileno(STREAM(sockpt)), &sad, &sadlen);); + if (-1==newsd) + if (EWOULDBLOCK != errno) return BOOL_F; + else wta(sockpt, "couldn't", s_accept); + SYSCALL(newfd = fdopen(newsd, "r+");); + if (!newfd) { + close(newsd); + wta(MAKINUM(newsd), (char *)NALLOC, s_port_type); + } + CAR(newpt) = tc16_fport | mode_bits("r+0"); + SETSTREAM(newpt, newfd); + i_setbuf0(newpt); + ALLOW_INTS; + return newpt; +} + +int sknm_print(exp, port, writing) + SCM exp; SCM port; int writing; +{ + lputs("#<", port); + switch (((struct sockaddr *)CDR(exp))->sa_family) { + case AF_UNIX: + lputs("unix-addr ", port); + lputs(((struct sockaddr_un *)CDR(exp))->sun_path, port); + break; + case AF_INET: + lputs("inet-addr ", port); + lputs(inet_ntoa(((struct sockaddr_in *)CDR(exp))->sin_addr), port); + lputc(':', port); + intprint(0L + ntohs(((struct sockaddr_in *)CDR(exp))->sin_port), 10, port); + break; + default: lputs(s_unkfam, port); + lputc(' ', port); + intprint(0L+((struct sockaddr *)CDR(exp))->sa_family, 10, port); + } + lputc('>', port); + return !0; +} +sizet sknm_free(p) + CELLPTR p; +{ + must_free(CHARS((SCM)p)); + return sizeof(struct sockaddr); +} +long tc16_sknm; +static smobfuns sknm_smob = {mark0, sknm_free, sknm_print, 0}; + +char s_sknm_family[] = "socket-name:family"; +SCM l_sknm_family(snm) + SCM snm; +{ + ASSERT(NIMP(snm) && TYP16(snm)==tc16_sknm, snm, ARG1, s_sknm_family); + return MAKINUM(((struct sockaddr *)CDR(snm))->sa_family + 0L); +} +char s_sknm_port_num[] = "socket-name:port-number"; +SCM l_sknm_port_num(snm) + SCM snm; +{ + ASRTGO(NIMP(snm) && TYP16(snm)==tc16_sknm, err1); + switch (((struct sockaddr *)CDR(snm))->sa_family) { + default: + err1: + wta(snm, (char *)ARG1, s_sknm_port_num); + case AF_INET: + return MAKINUM(ntohs(((struct sockaddr_in *)CDR(snm))->sin_port) + 0L); + } +} +char s_sknm_addr[] = "socket-name:address"; +SCM l_sknm_addr(snm) + SCM snm; +{ + ASRTGO(NIMP(snm) && TYP16(snm)==tc16_sknm, err1); + switch (((struct sockaddr *)CDR(snm))->sa_family) { + default: + err1: + wta(snm, (char *)ARG1, s_sknm_addr); + case AF_INET: + return ulong2num(ntohl(((struct sockaddr_in *)CDR(snm))->sin_addr.s_addr)); + case AF_UNIX: /* the manual says this won't work anyway */ + return makfrom0str(((struct sockaddr_un *)CDR(snm))->sun_path); + } +} + +SCM maksknm(sad) + struct sockaddr *sad; +{ + SCM sknm; + struct sockaddr *msknm; + NEWCELL(sknm); + DEFER_INTS; + msknm = (struct sockaddr *)must_malloc(0L+sizeof(struct sockaddr), "sknm"); + *msknm = *sad; + CAR(sknm) = tc16_sknm; + SETCDR(sknm, msknm); + ALLOW_INTS; + return sknm; +} + +static char s_getpeername[] = "getpeername"; +SCM l_getpeername(sockpt) + SCM sockpt; +{ + struct sockaddr_in sad; + int sts, sadlen = sizeof(sad); + bzero((char *) &sad, sizeof(sad)); + ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getpeername); + SYSCALL(sts = getpeername(fileno(STREAM(sockpt)), + (struct sockaddr*)&sad, &sadlen);); + if (sts || sizeof(sad) != sadlen) return BOOL_F; +/* ASSERT(sad.sin_family==AF_INET, sockpt, "non-internet", s_getpeername); */ + return maksknm(&sad); +} +static char s_getsockname[] = "getsockname"; +SCM l_getsockname(sockpt) + SCM sockpt; +{ + struct sockaddr_in sad; + int sts, sadlen = sizeof(sad); + bzero((char *) &sad, sizeof(sad)); + ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getsockname); + SYSCALL(sts = getsockname(fileno(STREAM(sockpt)), + (struct sockaddr*)&sad, &sadlen);); + if (sts || sizeof(sad) != sadlen) return BOOL_F; + return maksknm(&sad); +} +static iproc subr1s[] = { + {s_inetaddr, l_inetaddr}, + {s_inetstr, l_inetstr}, + {s_network, l_network}, + {s_lna, l_lna}, + {s_makaddr, l_makaddr}, + + {s_accept, l_accept}, + {s_sknm_family, l_sknm_family}, + {s_sknm_port_num, l_sknm_port_num}, + {s_sknm_addr, l_sknm_addr}, + {s_getpeername, l_getpeername}, + {s_getsockname, l_getsockname}, + {0, 0}}; + +static iproc subr1os[] = { + {s_hostinfo, l_hostinfo}, + {s_netinfo, l_netinfo}, + {s_protoinfo, l_protoinfo}, + {"sethostent", l_sethost}, + {"setnetent", l_setnet}, + {"setprotoent", l_setproto}, + {"setservent", l_setserv}, + {0, 0}}; + +static iproc subr2s[] = { + {s_shutdown, l_shutdown}, + {s_bind, l_bind}, + {s_listen, l_listen}, + {s_makaddr, l_makaddr}, + {0, 0}}; + +void init_socket() +{ + sysintern("af_unix", MAKINUM(AF_UNIX)); + sysintern("af_inet", MAKINUM(AF_INET)); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr1os, tc7_subr_1o); + init_iprocs(subr2s, tc7_subr_2); + make_subr(s_servinfo, tc7_lsubr, l_servinfo); + make_subr(s_socket, tc7_subr_2o, l_socket); + make_subr(s_socketpair, tc7_subr_2o, l_socketpair); + make_subr(s_connect, tc7_lsubr_2, l_connect); + tc16_sknm = newsmob(&sknm_smob); + add_feature("socket"); +} diff --git a/split.scm b/split.scm new file mode 100644 index 0000000..1230946 --- /dev/null +++ b/split.scm @@ -0,0 +1,87 @@ +;; Copyright (C) 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. + +;;;; "split.scm", split input, output, and error streams into windows. +;;; Author: Aubrey Jaffer. + +(require 'curses) +(define *stdscr* (initscr)) +(nocbreak) +(echo) +(nl) +(define subwindow-height (max 2 (quotient (output-port-height) 5))) +(define *output-window* + (newwin (- (output-port-height) (* 2 subwindow-height) 2) + (output-port-width) + 0 + 0)) +(define *input-window* + (newwin subwindow-height + (output-port-width) + (- (output-port-height) (* 2 subwindow-height) 1) + 0)) +(define *error-window* + (newwin subwindow-height + (output-port-width) + (- (output-port-height) subwindow-height) + 0)) +(wmove *stdscr* (- (output-port-height) subwindow-height 1) 0) +(wstandout *stdscr*) +(display (make-string (output-port-width) #\-) *stdscr*) +(wmove *stdscr* (- (output-port-height) (* 2 subwindow-height) 2) 0) +(display (make-string (output-port-width) #\-) *stdscr*) +(wstandend *stdscr*) +(touchwin *stdscr*) +(force-output *stdscr*) +(scrollok *output-window* #t) +(scrollok *input-window* #t) +(scrollok *error-window* #t) +(define *default-output-port* (set-current-output-port *output-window*)) +(define *default-input-port* (set-current-input-port *input-window*)) +(define *default-error-port* (set-current-error-port *error-window*)) +(leaveok *output-window* #t) +(leaveok *input-window* #f) +(leaveok *error-window* #t) + +(define (unsplit) + (cond ((endwin) + (set-current-output-port *default-output-port*) + (set-current-input-port *default-input-port*) + (set-current-error-port *default-error-port*)))) @@ -0,0 +1,2009 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "subr.c" integer and other Scheme procedures + Author: Aubrey Jaffer */ + +#include <ctype.h> +#include "scm.h" + +#define s_length (s_st_length+7) +#define s_append (s_st_append+7) + +char s_make_string[] = "make-string"; +char s_list[] = "list"; + +static char s_setcar[] = "set-car!", s_setcdr[] = "set-cdr!", + s_reverse[] = "reverse", s_list_ref[] = "list-ref"; +static char s_memq[] = "memq", s_member[] = "member", + s_assq[] = "assq", s_assoc[] = "assoc"; +static char s_symbol2string[] = "symbol->string", + s_str2symbol[] = "string->symbol"; +extern char s_inexactp[]; +#define s_exactp (s_inexactp+2) +static char s_oddp[] = "odd?", s_evenp[] = "even?"; +static char s_abs[] = "abs", s_quotient[] = "quotient", + s_remainder[] = "remainder", s_modulo[] = "modulo"; +static char s_gcd[] = "gcd"; + +static char s_ci_eq[] = "char-ci=?", + s_ch_lessp[] = "char<?", s_ch_leqp[] = "char<=?", + s_ci_lessp[] = "char-ci<?", s_ci_leqp[] = "char-ci<=?", + s_ch_grp[] = "char>?", s_ch_geqp[] = "char>=?", + s_ci_grp[] = "char-ci>?", s_ci_geqp[] = "char-ci>=?"; +static char s_ch_alphap[] = "char-alphabetic?", + s_ch_nump[] = "char-numeric?", + s_ch_whitep[] = "char-whitespace?", + s_ch_upperp[] = "char-upper-case?", + s_ch_lowerp[] = "char-lower-case?"; +static char s_char2int[] = "char->integer", s_int2char[] = "integer->char", + s_ch_upcase[] = "char-upcase", s_ch_downcase[] = "char-downcase"; + +static char s_st_length[] = "string-length", + s_st_ref[] = "string-ref", s_st_set[] = "string-set!"; +static char s_st_equal[] = "string=?", s_stci_equal[] = "string-ci=?", + s_st_lessp[] = "string<?", s_stci_lessp[] = "string-ci<?"; +static char s_substring[] = "substring", s_st_append[] = "string-append"; + +static char s_ve_length[] = "vector-length", + s_ve_ref[] = "vector-ref", s_ve_set[] = "vector-set!"; + +SCM lnot(x) + SCM x; +{ + return FALSEP(x) ? BOOL_T : BOOL_F; +} +SCM booleanp(obj) + SCM obj; +{ + if (BOOL_F==obj) return BOOL_T; + if (BOOL_T==obj) return BOOL_T; + return BOOL_F; +} +SCM eq(x, y) + SCM x, y; +{ + if (x==y) return BOOL_T; + else return BOOL_F; +} + +SCM consp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return CONSP(x) ? BOOL_T : BOOL_F; +} +SCM setcar(pair, value) + SCM pair, value; +{ + ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar); + CAR(pair) = value; + return UNSPECIFIED; +} +SCM setcdr(pair, value) + SCM pair, value; +{ + ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr); + CDR(pair) = value; + return UNSPECIFIED; +} +SCM nullp(x) + SCM x; +{ + return NULLP(x) ? BOOL_T : BOOL_F; +} +long ilength(sx) + SCM sx; +{ + register long i = 0; + register SCM x = sx; + do { + if IMP(x) return NULLP(x) ? i : -1; + if NCONSP(x) return -2; + x = CDR(x); + i++; + if IMP(x) return NULLP(x) ? i : -1; + if NCONSP(x) return -2; + x = CDR(x); + i++; + sx = CDR(sx); + } + while (x != sx); + return -1; +} +SCM listp(x) + SCM x; +{ + if (ilength(x)<0) return BOOL_F; + else return BOOL_T; +} +SCM list(objs) + SCM objs; +{ + return objs; +} +SCM length(x) + SCM x; +{ + SCM i = MAKINUM(ilength(x)); + ASSERT(i >= INUM0, x, ARG1, s_length); + return i; +} +SCM append(args) + SCM args; +{ + SCM res = EOL; + SCM *lloc = &res, arg; + if IMP(args) { + ASSERT(NULLP(args), args, ARGn, s_append); + return res; + } + ASSERT(CONSP(args), args, ARGn, s_append); + while (1) { + arg = CAR(args); + args = CDR(args); + if IMP(args) { + *lloc = arg; + ASSERT(NULLP(args), args, ARGn, s_append); + return res; + } + ASSERT(CONSP(args), args, ARGn, s_append); + for(;NIMP(arg);arg = CDR(arg)) { + ASSERT(CONSP(arg), arg, ARGn, s_append); + *lloc = cons(CAR(arg), EOL); + lloc = &CDR(*lloc); + } + ASSERT(NULLP(arg), arg, ARGn, s_append); + } +} +SCM reverse(lst) + SCM lst; +{ + SCM res = EOL; + SCM p = lst; + for(;NIMP(p);p = CDR(p)) { + ASSERT(CONSP(p), lst, ARG1, s_reverse); + res = cons(CAR(p), res); + } + ASSERT(NULLP(p), lst, ARG1, s_reverse); + return res; +} +SCM list_ref(lst, k) + SCM lst, k; +{ + register long i; + ASSERT(INUMP(k), k, ARG2, s_list_ref); + i = INUM(k); + ASSERT(i >= 0, k, ARG2, s_list_ref); + while (i-- > 0) { + ASRTGO(NIMP(lst) && CONSP(lst), erout); + lst = CDR(lst); + } +erout: ASSERT(NIMP(lst) && CONSP(lst), + NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref); + return CAR(lst); +} +SCM memq(x, lst) + SCM x, lst; +{ + for(;NIMP(lst);lst = CDR(lst)) { + ASSERT(CONSP(lst), lst, ARG2, s_memq); + if (CAR(lst)==x) return lst; + } + ASSERT(NULLP(lst), lst, ARG2, s_memq); + return BOOL_F; +} +SCM member(x, lst) + SCM x, lst; +{ + for(;NIMP(lst);lst = CDR(lst)) { + ASSERT(CONSP(lst), lst, ARG2, s_member); + if NFALSEP(equal(CAR(lst), x)) return lst; + } + ASSERT(NULLP(lst), lst, ARG2, s_member); + return BOOL_F; +} +SCM assq(x, alist) + SCM x, alist; +{ + SCM tmp; + for(;NIMP(alist);alist = CDR(alist)) { + ASSERT(CONSP(alist), alist, ARG2, s_assq); + tmp = CAR(alist); + ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq); + if (CAR(tmp)==x) return tmp; + } + ASSERT(NULLP(alist), alist, ARG2, s_assq); + return BOOL_F; +} +SCM assoc(x, alist) + SCM x, alist; +{ + SCM tmp; + for(;NIMP(alist);alist = CDR(alist)) { + ASSERT(CONSP(alist), alist, ARG2, s_assoc); + tmp = CAR(alist); + ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc); + if NFALSEP(equal(CAR(tmp), x)) return tmp; + } + ASSERT(NULLP(alist), alist, ARG2, s_assoc); + return BOOL_F; +} + +SCM symbolp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return SYMBOLP(x) ? BOOL_T : BOOL_F; +} +SCM symbol2string(s) + SCM s; +{ + ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string); + return makfromstr(CHARS(s), (sizet)LENGTH(s)); +} +SCM string2symbol(s) + SCM s; +{ + ASSERT(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol); + s = intern(CHARS(s), (sizet)LENGTH(s)); + return CAR(s); +} + +SCM exactp(x) + SCM x; +{ + if INUMP(x) return BOOL_T; +#ifdef BIGDIG + if (NIMP(x) && BIGP(x)) return BOOL_T; +#endif + return BOOL_F; +} +SCM oddp(n) + SCM n; +{ +#ifdef BIGDIG + if NINUMP(n) { + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_oddp); + return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F; + } +#else + ASSERT(INUMP(n), n, ARG1, s_oddp); +#endif + return (4 & (int)n) ? BOOL_T : BOOL_F; +} +SCM evenp(n) + SCM n; +{ +#ifdef BIGDIG + if NINUMP(n) { + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_evenp); + return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T; + } +#else + ASSERT(INUMP(n), n, ARG1, s_evenp); +#endif + return (4 & (int)n) ? BOOL_F : BOOL_T; +} +SCM absval(x) + SCM x; +{ +#ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_abs); + if (TYP16(x)==tc16_bigpos) return x; + return copybig(x, 0); + } +#else + ASSERT(INUMP(x), x, ARG1, s_abs); +#endif + if (INUM(x) >= 0) return x; + x = -INUM(x); + if (!POSFIXABLE(x)) +#ifdef BIGDIG + return long2big(x); +#else + wta(MAKINUM(-x), (char *)OVFLOW, s_abs); +#endif + return MAKINUM(x); +} +SCM lquotient(x, y) + SCM x, y; +{ + register long z; +#ifdef BIGDIG + if NINUMP(x) { + long w; + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_quotient); + if NINUMP(y) { + ASRTGO(NIMP(y) && BIGP(y), bady); + return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y), 2); + } + z = INUM(y); + ASRTGO(z, ov); + if (1==z) return x; + if (z < 0) z = -z; + if (z < BIGRAD) { + w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); + divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z); + return normbig(w); + } +# ifndef DIGSTOOBIG + w = pseudolong(z); + return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&w, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 2); +# else + { BIGDIG zdigs[DIGSPERLONG]; + longdigs(z, zdigs); + return divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 2); + } +# endif + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_quotient); +# endif + return INUM0; + } +#else + ASSERT(INUMP(x), x, ARG1, s_quotient); + ASSERT(INUMP(y), y, ARG2, s_quotient); +#endif + if ((z = INUM(y))==0) + ov: wta(y, (char *)OVFLOW, s_quotient); + z = INUM(x)/z; +#ifdef BADIVSGNS + { +# if (__TURBOC__==1) + long t = ((y<0) ? -INUM(x) : INUM(x))%INUM(y); +# else + long t = INUM(x)%INUM(y); +# endif + if (t==0) ; + else if (t < 0) + if (x < 0) ; + else z--; + else if (x < 0) z++; + } +#endif + if (!FIXABLE(z)) +#ifdef BIGDIG + return long2big(z); +#else + wta(x, (char *)OVFLOW, s_quotient); +#endif + return MAKINUM(z); +} +SCM lremainder(x, y) + SCM x, y; +{ + register long z; +#ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_remainder); + if NINUMP(y) { + ASRTGO(NIMP(y) && BIGP(y), bady); + return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x), 0); + } + if (!(z = INUM(y))) goto ov; + return divbigint(x, z, BIGSIGN(x), 0); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_remainder); +# endif + return x; + } +#else + ASSERT(INUMP(x), x, ARG1, s_remainder); + ASSERT(INUMP(y), y, ARG2, s_remainder); +#endif + if (!(z = INUM(y))) + ov: wta(y, (char *)OVFLOW, s_remainder); +#if (__TURBOC__==1) + if (z < 0) z = -z; +#endif + z = INUM(x)%z; +#ifdef BADIVSGNS + if (!z) ; + else if (z < 0) + if (x < 0) ; + else z += INUM(y); + else if (x < 0) z -= INUM(y); +#endif + return MAKINUM(z); +} +SCM modulo(x, y) + SCM x, y; +{ + register long yy, z; +#ifdef BIGDIG + if NINUMP(x) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_modulo); + if NINUMP(y) { + ASRTGO(NIMP(y) && BIGP(y), bady); + return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0); + } + if (!(z = INUM(y))) goto ov; + return divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_modulo); +# endif + return (BIGSIGN(y) ? (x>0) : (x<0)) ? sum(x, y) : x; + } +#else + ASSERT(INUMP(x), x, ARG1, s_modulo); + ASSERT(INUMP(y), y, ARG2, s_modulo); +#endif + if (!(yy = INUM(y))) + ov: wta(y, (char *)OVFLOW, s_modulo); +#if (__TURBOC__==1) + z = INUM(x); + z = ((yy<0) ? -z : z)%yy; +#else + z = INUM(x)%yy; +#endif + return MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z); +} + +SCM lgcd(x, y) + SCM x, y; +{ + register long u, v, k, t; + tailrec: + if UNBNDP(y) return UNBNDP(x) ? INUM0 : x; +#ifdef BIGDIG + if NINUMP(x) { + big_gcd: + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_gcd); + if BIGSIGN(x) x = copybig(x, 0); + newy: + if NINUMP(y) { + ASSERT(NIMP(y) && BIGP(y), y, ARG2, s_gcd); + if BIGSIGN(y) y = copybig(y, 0); + switch (bigcomp(x, y)) { + case -1: + swaprec: t = lremainder(x, y); x = y; y = t; goto tailrec; + case 0: return x; + case 1: y = lremainder(y, x); goto newy; + } + /* instead of the switch, we could just return lgcd(y, modulo(x, y)); */ + } + if (INUM0==y) return x; goto swaprec; + } + if NINUMP(y) { t=x; x=y; y=t; goto big_gcd;} +#else + ASSERT(INUMP(x), x, ARG1, s_gcd); + ASSERT(INUMP(y), y, ARG2, s_gcd); +#endif + u = INUM(x); + if (u<0) u = -u; + v = 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 = 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 (!POSFIXABLE(u)) +#ifdef BIGDIG + return long2big(u); +#else + wta(x, (char *)OVFLOW, s_gcd); +#endif + return MAKINUM(u); +} +SCM llcm(n1, n2) + SCM n1, n2; +{ + SCM d; + if UNBNDP(n2) { + n2 = MAKINUM(1L); + if UNBNDP(n1) return n2; + } + d = lgcd(n1, n2); + if (INUM0==d) return d; + return absval(product(n1, lquotient(n2, d))); +} + +/* Emulating 2's complement bignums with sign magnitude arithmetic: + + Logand: + X Y Result Method: + (len) + + + + x (map digit:logand X Y) + + - + x (map digit:logand X (lognot (+ -1 Y))) + - + + y (map digit:logand (lognot (+ -1 X)) Y) + - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y))) + + Logior: + X Y Result Method: + + + + + (map digit:logior X Y) + + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y))) + - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y))) + - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y))) + + Logxor: + X Y Result Method: + + + + + (map digit:logxor X Y) + + - - (+ 1 (map digit:logxor X (+ -1 Y))) + - + - (+ 1 (map digit:logxor (+ -1 X) Y)) + - - + (map digit:logxor (+ -1 X) (+ -1 Y)) + + Logtest: + X Y Result + + + + (any digit:logand X Y) + + - (any digit:logand X (lognot (+ -1 Y))) + - + (any digit:logand (lognot (+ -1 X)) Y) + - - #t + +*/ + +#ifdef BIGDIG + +SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); +SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn)); +SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); +SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy)); + +SCM scm_copy_big_dec(b, sign) + SCM b; + int sign; +{ + long num = -1; + sizet nx = NUMDIGS(b); + sizet i = 0; + SCM ans = mkbig(nx, sign); + BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans); + if BIGSIGN(b) do { + num += src[i]; + if (num < 0) {dst[i] = num + BIGRAD; num = -1;} + else {dst[i] = BIGLO(num); num = 0;} + } while (++i < nx); + else + while (nx--) dst[nx] = src[nx]; + return ans; +} + +SCM scm_copy_smaller(x, nx, zsgn) + BIGDIG *x; + sizet nx; + int zsgn; +{ + long num = -1; + sizet i = 0; + SCM z = mkbig(nx, zsgn); + BIGDIG *zds = BDIGITS(z); + if (zsgn) do { + num += x[i]; + if (num < 0) {zds[i] = num + BIGRAD; num = -1;} + else {zds[i] = BIGLO(num); num = 0;} + } while (++i < nx); + else do zds[i] = x[i]; while (++i < nx); + return z; +} + +SCM scm_big_ior(x, nx, xsgn, bigy) + BIGDIG *x; + SCM bigy; + sizet nx; /* Assumes nx <= NUMDIGS(bigy) */ + int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */ +{ + long num = -1; + sizet i = 0, ny = NUMDIGS(bigy); + SCM z = scm_copy_big_dec(bigy, xsgn & BIGSIGN(bigy)); + BIGDIG *zds = BDIGITS(z); + if (xsgn) { + do { + num += x[i]; + if (num < 0) {zds[i] |= num + BIGRAD; num = -1;} + else {zds[i] |= BIGLO(num); num = 0;} + } while (++i < nx); + /* ========= Need to increment zds now =========== */ + i = 0; num = 1; + while (i < ny) { + num += zds[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + if (!num) return z; + } + adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */ + BDIGITS(z)[ny] = 1; + return z; + } + else do zds[i] = zds[i] | x[i]; while (++i < nx); + return z; +} + +SCM scm_big_xor(x, nx, xsgn, bigy) + BIGDIG *x; + SCM bigy; + sizet nx; /* Assumes nx <= NUMDIGS(bigy) */ + int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */ +{ + long num = -1; + sizet i = 0, ny = NUMDIGS(bigy); + SCM z = scm_copy_big_dec(bigy, xsgn ^ BIGSIGN(bigy)); + BIGDIG *zds = BDIGITS(z); + if (xsgn) do { + num += x[i]; + if (num < 0) {zds[i] ^= num + BIGRAD; num = -1;} + else {zds[i] ^= BIGLO(num); num = 0;} + } while (++i < nx); + else do { + zds[i] = zds[i] ^ x[i]; + } while (++i < nx); + + if (xsgn ^ BIGSIGN(bigy)) { + /* ========= Need to increment zds now =========== */ + i = 0; num = 1; + while (i < ny) { + num += zds[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + if (!num) return normbig(z); + } + } + return normbig(z); +} + +SCM scm_big_and(x, nx, xsgn, bigy, zsgn) + BIGDIG *x; + SCM bigy; + sizet nx; /* Assumes nx <= NUMDIGS(bigy) */ + int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */ + int zsgn; /* return sign equals either 0 or 0x0100 */ +{ + long num = -1; + sizet i = 0; + SCM z; + BIGDIG *zds; + if (xsgn==zsgn) { + z = scm_copy_smaller(x, nx, zsgn); + x = BDIGITS(bigy); + xsgn = BIGSIGN(bigy); + } + else z = scm_copy_big_dec(bigy, zsgn); + zds = BDIGITS(z); + + if (zsgn) { + if (xsgn) do { + num += x[i]; + if (num < 0) {zds[i] &= num + BIGRAD; num = -1;} + else {zds[i] &= BIGLO(num); num = 0;} + } while (++i < nx); + else do zds[i] = zds[i] & ~x[i]; while (++i < nx); + /* ========= need to increment zds now =========== */ + i = 0; num = 1; + while (i < nx) { + num += zds[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + if (!num) return normbig(z); + } + } + else if (xsgn) do { + num += x[i]; + if (num < 0) {zds[i] &= num + BIGRAD; num = -1;} + else {zds[i] &= ~BIGLO(num); num = 0;} + } while (++i < nx); + else do zds[i] = zds[i] & x[i]; while (++i < nx); + return normbig(z); +} + +SCM scm_big_test(x, nx, xsgn, bigy) + BIGDIG *x; + SCM bigy; + sizet nx; /* Assumes nx <= NUMDIGS(bigy) */ + int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */ +{ + BIGDIG *y; + sizet i = 0; + long num = -1; + if (BIGSIGN(bigy) & xsgn) return BOOL_T; + if (NUMDIGS(bigy) != nx && xsgn) return BOOL_T; + y = BDIGITS(bigy); + if (xsgn) + do { + num += x[i]; + if (num < 0) { + if (y[i] & ~(num + BIGRAD)) return BOOL_T; + num = -1; + } + else { + if (y[i] & ~BIGLO(num)) return BOOL_T; + num = 0; + } + } while (++i < nx); + else if BIGSIGN(bigy) + do { + num += y[i]; + if (num < 0) { + if (x[i] & ~(num + BIGRAD)) return BOOL_T; + num = -1; + } + else { + if (x[i] & ~BIGLO(num)) return BOOL_T; + num = 0; + } + } while (++i < nx); + else + do if (x[i] & y[i]) return BOOL_T; + while (++i < nx); + return BOOL_F; +} + +#endif + +static char s_logand[] = "logand", s_lognot[] = "lognot", + s_logior[] = "logior", s_logxor[] = "logxor", + s_logtest[] = "logtest", s_logbitp[] = "logbit?", + s_ash[] = "ash", s_logcount[] = "logcount", + s_intlength[] = "integer-length", + s_intexpt[] = "integer-expt", + s_bitextract[] = "bit-extract"; + +SCM scm_logior(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return INUM0; +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_logior); +#endif + return x; + } +#ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + if ((!BIGSIGN(x)) && !BIGSIGN(y)) + return scm_big_ior(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y); + return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_logior); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + if ((!(x < 0)) && !BIGSIGN(y)) + return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); + return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, + 0x0100); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + if ((!(x < 0)) && !BIGSIGN(y)) + return scm_big_ior(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); + return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# endif + }} +#else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_logior); +#endif + return MAKINUM(INUM(x) | INUM(y)); +} + +SCM scm_logand(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return MAKINUM(-1); +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_logand); +#endif + return x; + } +#ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + if ((BIGSIGN(x)) && BIGSIGN(y)) + return scm_big_ior(BDIGITS(x), NUMDIGS(x), 0x0100, y); + return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_logand); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + if ((x < 0) && BIGSIGN(y)) + return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, 0x0100, y); + return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, + 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + if ((x < 0) && BIGSIGN(y)) + return scm_big_ior(zdigs, DIGSPERLONG, 0x0100, y); + return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# endif + }} +#else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_logand); +#endif + return MAKINUM(INUM(x) & INUM(y)); +} + +SCM scm_logxor(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return INUM0; +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_logxor); +#endif + return x; + } +#ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + return scm_big_xor(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_logxor); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return scm_big_xor((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return scm_big_xor(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); +# endif + }} +#else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_logxor); +#endif + return (x ^ y) + INUM0; +} + +SCM scm_logtest(x, y) + SCM x, y; +{ +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_logtest); +#endif +#ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + if INUMP(y) {t = x; x = y; y = t; goto intbig;} + ASRTGO(NIMP(y) && BIGP(y), bady); + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + return scm_big_test(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y); + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_logtest); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return scm_big_test((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return scm_big_test(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y); +# endif + }} +#else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_logtest); +#endif + return (INUM(x) & INUM(y)) ? BOOL_T : BOOL_F; +} + +SCM scm_logbitp(index, j1) + SCM index, j1; +{ + ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp); +#ifdef BIGDIG + if NINUMP(j1) { + ASSERT(NIMP(j1) && BIGP(j1), j1, (char *)ARG2, s_logbitp); + if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F; + else if BIGSIGN(j1) { + long num = -1; + sizet i = 0; + BIGDIG *x = BDIGITS(j1); + sizet nx = INUM(index)/BITSPERDIG; + while (!0) { + num += x[i]; + if (nx==i++) + return ((1L << (INUM(index)%BITSPERDIG)) & num) ? BOOL_F : BOOL_T; + if (num < 0) num = -1; + else num = 0; + } + } + else return (BDIGITS(j1)[INUM(index)/BITSPERDIG] & + (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F; + } +#else + ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp); +#endif + return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F; +} + +SCM scm_lognot(n) + SCM n; +{ + return difference(MAKINUM(-1L), n); +} + +SCM scm_intexpt(z1, z2) + SCM z1, z2; +{ + SCM acc = MAKINUM(1L); +#ifdef BIGDIG + if (INUM0==z1 || acc==z1) return z1; + else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; +#endif + ASSERT(INUMP(z2), z2, ARG2, s_intexpt); + z2 = INUM(z2); + if (z2 < 0) { + z2 = -z2; + z1 = divide(z1, UNDEFINED); + } + while(1) { + if (0==z2) return acc; + if (1==z2) return product(acc, z1); + if (z2 & 1) acc = product(acc, z1); + z1 = product(z1, z1); + z2 >>= 1; + } +} +SCM scm_ash(n, cnt) + SCM n, cnt; +{ + SCM res = INUM(n); + ASSERT(INUMP(cnt), cnt, ARG2, s_ash); +#ifdef BIGDIG + if(cnt < 0) { + res = scm_intexpt(MAKINUM(2), MAKINUM(-INUM(cnt))); + if NFALSEP(negativep(n)) + return sum(MAKINUM(-1L), lquotient(sum(MAKINUM(1L), n), res)); + else return lquotient(n, res); + } + else return product(n, scm_intexpt(MAKINUM(2), cnt)); +#else + ASSERT(INUMP(n), n, ARG1, s_ash); + cnt = INUM(cnt); + if (cnt < 0) return MAKINUM(SRS(res, -cnt)); + res = MAKINUM(res<<cnt); + if (INUM(res)>>cnt != INUM(n)) wta(n, (char *)OVFLOW, s_ash); + return res; +#endif +} + +SCM scm_bitextract(n, start, end) + SCM n, start, end; +{ + ASSERT(INUMP(start), start, ARG2, s_bitextract); + ASSERT(INUMP(end), end, ARG3, s_bitextract); + start = INUM(start); end = INUM(end); + ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitextract); +#ifdef BIGDIG + if NINUMP(n) + return + scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)), + MAKINUM(1L)), + scm_ash(n, MAKINUM(-start))); +#else + ASSERT(INUMP(n), n, ARG1, s_bitextract); +#endif + return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1)); +} + +char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; +SCM scm_logcount(n) + SCM n; +{ + register unsigned long c = 0; + register long nn; +#ifdef BIGDIG + if NINUMP(n) { + sizet i; BIGDIG *ds, d; + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_logcount); + if BIGSIGN(n) return scm_logcount(difference(MAKINUM(-1L), n)); + ds = BDIGITS(n); + for(i = NUMDIGS(n); i--; ) + for(d = ds[i]; d; d >>= 4) c += logtab[15 & d]; + return MAKINUM(c); + } +#else + ASSERT(INUMP(n), n, ARG1, s_logcount); +#endif + if ((nn = INUM(n)) < 0) nn = -1 - nn; + for(; nn; nn >>= 4) c += logtab[15 & nn]; + return MAKINUM(c); +} + +char ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4}; +SCM scm_intlength(n) + SCM n; +{ + register unsigned long c = 0; + register long nn; + unsigned int l = 4; +#ifdef BIGDIG + if NINUMP(n) { + BIGDIG *ds, d; + ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_intlength); + if BIGSIGN(n) return scm_intlength(difference(MAKINUM(-1L), n)); + ds = BDIGITS(n); + d = ds[c = NUMDIGS(n)-1]; + for(c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];} + return MAKINUM(c - 4 + l); + } +#else + ASSERT(INUMP(n), n, ARG1, s_intlength); +#endif + if ((nn = INUM(n)) < 0) nn = -1 - nn; + for(;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];} + return MAKINUM(c - 4 + l); +} + +SCM charp(x) + SCM x; +{ + return ICHRP(x) ? BOOL_T : BOOL_F; +} +SCM char_lessp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ch_lessp); + ASSERT(ICHRP(y), y, ARG2, s_ch_lessp); + return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F; +} +SCM char_leqp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ch_leqp); + ASSERT(ICHRP(y), y, ARG2, s_ch_leqp); + return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F; +} +SCM char_grp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ch_grp); + ASSERT(ICHRP(y), y, ARG2, s_ch_grp); + return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F; +} +SCM char_geqp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ch_geqp); + ASSERT(ICHRP(y), y, ARG2, s_ch_geqp); + return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F; +} +SCM chci_eq(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ci_eq); + ASSERT(ICHRP(y), y, ARG2, s_ci_eq); + return (upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F; +} +SCM chci_lessp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ci_lessp); + ASSERT(ICHRP(y), y, ARG2, s_ci_lessp); + return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F; +} +SCM chci_leqp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ci_leqp); + ASSERT(ICHRP(y), y, ARG2, s_ci_leqp); + return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F; +} +SCM chci_grp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ci_grp); + ASSERT(ICHRP(y), y, ARG2, s_ci_grp); + return (upcase[ICHR(x)] > upcase[ICHR(y)]) ? BOOL_T : BOOL_F; +} +SCM chci_geqp(x, y) + SCM x, y; +{ + ASSERT(ICHRP(x), x, ARG1, s_ci_geqp); + ASSERT(ICHRP(y), y, ARG2, s_ci_geqp); + return (upcase[ICHR(x)] >= upcase[ICHR(y)]) ? BOOL_T : BOOL_F; +} +SCM char_alphap(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_alphap); + return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F; +} +SCM char_nump(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_nump); + return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F; +} +SCM char_whitep(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_whitep); + return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F; +} +SCM char_upperp(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_upperp); + return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F; +} +SCM char_lowerp(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_lowerp); + return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F; +} +SCM char2int(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_char2int); + return MAKINUM(ICHR(chr)); +} +SCM int2char(n) + SCM n; +{ + ASSERT(INUMP(n), n, ARG1, s_int2char); + ASSERT((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)), + n, OUTOFRANGE, s_int2char); + return MAKICHR(INUM(n)); +} +SCM char_upcase(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_upcase); + return MAKICHR(upcase[ICHR(chr)]); +} +SCM char_downcase(chr) + SCM chr; +{ + ASSERT(ICHRP(chr), chr, ARG1, s_ch_downcase); + return MAKICHR(downcase[ICHR(chr)]); +} + +SCM stringp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return STRINGP(x) ? BOOL_T : BOOL_F; +} +SCM string(chrs) + SCM chrs; +{ + SCM res; + register char *data; + long i = ilength(chrs); + ASSERT(i >= 0, chrs, ARG1, s_string); + res = makstr(i); + data = CHARS(res); + for(;NNULLP(chrs);chrs = CDR(chrs)) { + ASSERT(ICHRP(CAR(chrs)), chrs, ARG1, s_string); + *data++ = ICHR(CAR(chrs)); + } + return res; +} +SCM make_string(k, chr) + SCM k, chr; +{ + SCM res; + register char *dst; + register long i; + ASSERT(INUMP(k) && (k >= 0), k, ARG1, s_make_string); + i = INUM(k); + res = makstr(i); + dst = CHARS(res); + if (!UNBNDP(chr)) { + ASSERT(ICHRP(chr), chr, ARG2, s_make_string); + for(i--;i >= 0;i--) dst[i] = ICHR(chr); + } + return res; +} +SCM st_length(str) + SCM str; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_length); + return MAKINUM(LENGTH(str)); +} +SCM st_ref(str, k) + SCM str, k; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref); + ASSERT(INUMP(k), k, ARG2, s_st_ref); + ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref); + return MAKICHR(CHARS(str)[INUM(k)]); +} +SCM st_set(str, k, chr) + SCM str, k, chr; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_set); + ASSERT(INUMP(k), k, ARG2, s_st_set); + ASSERT(ICHRP(chr), chr, ARG3, s_st_set); + ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set); + CHARS(str)[INUM(k)] = ICHR(chr); + return UNSPECIFIED; +} +SCM st_equal(s1, s2) + SCM s1, s2; +{ + register sizet i; + register char *c1, *c2; + ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal); + ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal); + i = LENGTH(s2); + if (LENGTH(s1) != i) return BOOL_F; + c1 = CHARS(s1); + c2 = CHARS(s2); + while(0 != i--) if(*c1++ != *c2++) return BOOL_F; + return BOOL_T; +} +SCM stci_equal(s1, s2) + SCM s1, s2; +{ + register sizet i; + register unsigned char *c1, *c2; + ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal); + ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal); + i = LENGTH(s2); + if (LENGTH(s1) != i) return BOOL_F; + c1 = UCHARS(s1); + c2 = UCHARS(s2); + while(0 != i--) if(upcase[*c1++] != upcase[*c2++]) return BOOL_F; + return BOOL_T; +} +SCM st_lessp(s1, s2) + SCM s1, s2; +{ + register sizet i, len; + register unsigned char *c1, *c2; + register int c; + ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp); + ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp); + len = LENGTH(s1); + i = LENGTH(s2); + if (len>i) i = len; + c1 = UCHARS(s1); + c2 = UCHARS(s2); + for(i = 0;i<len;i++) { + c = (*c1++ - *c2++); + if (c>0) return BOOL_F; + if (c<0) return BOOL_T; + } + return (LENGTH(s2) != len) ? BOOL_T : BOOL_F; +} +SCM st_leqp(s1, s2) + SCM s1, s2; +{ + return BOOL_NOT(st_lessp(s2, s1)); +} +SCM st_grp(s1, s2) + SCM s1, s2; +{ + return st_lessp(s2, s1); +} +SCM st_geqp(s1, s2) + SCM s1, s2; +{ + return BOOL_NOT(st_lessp(s1, s2)); +} +SCM stci_lessp(s1, s2) + SCM s1, s2; +{ + register sizet i, len; + register unsigned char *c1, *c2; + register int c; + ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp); + ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp); + len = LENGTH(s1); + i = LENGTH(s2); + if (len>i) i=len; + c1 = UCHARS(s1); + c2 = UCHARS(s2); + for(i = 0;i<len;i++) { + c = (upcase[*c1++] - upcase[*c2++]); + if (c>0) return BOOL_F; + if (c<0) return BOOL_T; + } + return (LENGTH(s2) != len) ? BOOL_T : BOOL_F; +} +SCM stci_leqp(s1, s2) + SCM s1, s2; +{ + return BOOL_NOT(stci_lessp(s2, s1)); +} +SCM stci_grp(s1, s2) + SCM s1, s2; +{ + return stci_lessp(s2, s1); +} +SCM stci_geqp(s1, s2) + SCM s1, s2; +{ + return BOOL_NOT(stci_lessp(s1, s2)); +} +SCM substring(str, start, end) + SCM str, start, end; +{ + long l; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_substring); + ASSERT(INUMP(start), start, ARG2, s_substring); + ASSERT(INUMP(end), end, ARG3, s_substring); + ASSERT(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring); + ASSERT(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring); + l = INUM(end)-INUM(start); + ASSERT(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring); + return makfromstr(&CHARS(str)[INUM(start)], (sizet)l); +} +SCM st_append(args) + SCM args; +{ + SCM res; + register long i = 0; + register SCM l, s; + register char *data; + for(l = args;NIMP(l);) { + ASSERT(CONSP(l), l, ARGn, s_st_append); + s = CAR(l); + ASSERT(NIMP(s) && STRINGP(s), s, ARGn, s_st_append); + i += LENGTH(s); + l = CDR(l); + } + ASSERT(NULLP(l), args, ARGn, s_st_append); + res = makstr(i); + data = CHARS(res); + for(l = args;NIMP(l);l = CDR(l)) { + s = CAR(l); + for(i = 0;i<LENGTH(s);i++) *data++ = CHARS(s)[i]; + } + return res; +} + +SCM vectorp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return VECTORP(x) ? BOOL_T : BOOL_F; +} +SCM vector_length(v) + SCM v; +{ + ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length); + return MAKINUM(LENGTH(v)); +} +SCM vector(l) + SCM l; +{ + SCM res; + register SCM *data; + long i = ilength(l); + ASSERT(i >= 0, l, ARG1, s_vector); + res = make_vector(MAKINUM(i), UNSPECIFIED); + data = VELTS(res); + for(;NIMP(l);l = CDR(l)) *data++ = CAR(l); + return res; +} +SCM vector_ref(v, k) + SCM v, k; +{ + ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref); + ASSERT(INUMP(k), k, ARG2, s_ve_ref); + ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref); + return VELTS(v)[((long) INUM(k))]; +} +SCM vector_set(v, k, obj) + SCM v, k, obj; +{ + ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set); + ASSERT(INUMP(k), k, ARG2, s_ve_set); + ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set); + VELTS(v)[((long) INUM(k))] = obj; + return UNSPECIFIED; +} +char s_make_vector[] = "make-vector"; +SCM make_vector(k, fill) + SCM k, fill; +{ + SCM v; + register long i; + register SCM *velts; + ASSERT(INUMP(k), k, ARG1, s_make_vector); + if UNBNDP(fill) fill = UNSPECIFIED; + i = INUM(k); + NEWCELL(v); + DEFER_INTS; + SETCHARS(v, must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector)); + SETLENGTH(v, i, tc7_vector); + velts = VELTS(v); + while(--i >= 0) (velts)[i] = fill; + ALLOW_INTS; + return v; +} +#ifdef BIGDIG +char s_bignum[] = "bignum"; +SCM mkbig(nlen, sign) + sizet nlen; + int sign; +{ + SCM v = nlen; + if (((v << 16) >> 16) != nlen) + wta(MAKINUM(v), (char *)NALLOC, s_bignum); + NEWCELL(v); + DEFER_INTS; + SETCHARS(v, must_malloc((long)(nlen*sizeof(BIGDIG)), s_bignum)); + SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos); + ALLOW_INTS; + return v; +} +SCM big2inum(b, l) + SCM b; + sizet l; +{ + unsigned long num = 0; + BIGDIG *tmp = BDIGITS(b); + while (l--) num = BIGUP(num) + tmp[l]; + if (TYP16(b)==tc16_bigpos) { + if POSFIXABLE(num) return MAKINUM(num); + } + else if UNEGFIXABLE(num) return MAKINUM(-num); + return b; +} +char s_adjbig[] = "adjbig"; +SCM adjbig(b, nlen) + SCM b; + sizet nlen; +{ + long nsiz = nlen; + if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig); + DEFER_INTS; + SETCHARS(b, (BIGDIG *)must_realloc((char *)CHARS(b), + (long)(NUMDIGS(b)*sizeof(BIGDIG)), + (long)(nsiz*sizeof(BIGDIG)), s_adjbig)); + SETNUMDIGS(b, nsiz, TYP16(b)); + ALLOW_INTS; + return b; +} +SCM normbig(b) + SCM b; +{ +# ifndef _UNICOS + sizet nlen = NUMDIGS(b); +# else + int nlen = NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */ +# endif + BIGDIG *zds = BDIGITS(b); + while (nlen-- && !zds[nlen]); nlen++; + if (nlen * BITSPERDIG/CHAR_BIT <= sizeof(SCM)) + if INUMP(b = big2inum(b, (sizet)nlen)) return b; + if (NUMDIGS(b)==nlen) return b; + return adjbig(b, (sizet)nlen); +} +SCM copybig(b, sign) + SCM b; + int sign; +{ + sizet i = NUMDIGS(b); + SCM ans = mkbig(i, sign); + BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans); + while (i--) dst[i] = src[i]; + return ans; +} +SCM long2big(n) + long n; +{ + sizet i = 0; + BIGDIG *digits; + SCM ans = mkbig(DIGSPERLONG, n<0); + digits = BDIGITS(ans); + if (n < 0) n = -n; + while (i < DIGSPERLONG) { + digits[i++] = BIGLO(n); + n = BIGDN((unsigned long)n); + } + return ans; +} +SCM ulong2big(n) + unsigned long n; +{ + sizet i = 0; + BIGDIG *digits; + SCM ans = mkbig(DIGSPERLONG, 0); + digits = BDIGITS(ans); + while (i < DIGSPERLONG) { + digits[i++] = BIGLO(n); + n = BIGDN(n); + } + return ans; +} + +int bigcomp(x, y) + SCM x, y; +{ + int xsign = BIGSIGN(x); + int ysign = BIGSIGN(y); + sizet xlen, ylen; + if (ysign < xsign) return 1; + if (ysign > xsign) return -1; + if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1; + if (ylen < xlen) return (xsign) ? 1 : -1; + while(xlen-- && (BDIGITS(y)[xlen]==BDIGITS(x)[xlen])); + if (-1==xlen) return 0; + return (BDIGITS(y)[xlen] > BDIGITS(x)[xlen]) ? + (xsign ? -1 : 1) : (xsign ? 1 : -1); +} + +# ifndef DIGSTOOBIG +long pseudolong(x) + long x; +{ + union { + long l; + BIGDIG bd[DIGSPERLONG]; + } p; + sizet i = 0; + if (x < 0) x = -x; + while (i < DIGSPERLONG) {p.bd[i++] = BIGLO(x); x = BIGDN(x);} +/* p.bd[0] = BIGLO(x); p.bd[1] = BIGDN(x); */ + return p.l; +} +# else +void longdigs(x, digs) + long x; + BIGDIG digs[DIGSPERLONG]; +{ + sizet i = 0; + if (x < 0) x = -x; + while (i < DIGSPERLONG) {digs[i++] = BIGLO(x); x = BIGDN(x);} +} +# endif + +SCM addbig(x, nx, xsgn, bigy, sgny) + BIGDIG *x; + SCM bigy; + sizet nx; /* Assumes nx <= NUMDIGS(bigy) */ + int xsgn, sgny; /* Assumes xsgn and sgny equal either 0 or 0x0100 */ +{ + long num = 0; + sizet i = 0, ny = NUMDIGS(bigy); + SCM z = copybig(bigy, BIGSIGN(bigy) ^ sgny); + BIGDIG *zds = BDIGITS(z); + if (xsgn ^ BIGSIGN(z)) { + do { + num += (long) zds[i] - x[i]; + if (num < 0) {zds[i] = num + BIGRAD; num = -1;} + else {zds[i] = BIGLO(num); num = 0;} + } while (++i < nx); + if (num && nx==ny) { + num = 1; i = 0; + CAR(z) ^= 0x0100; + do { + num += (BIGRAD-1) - zds[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + } while (i < ny); + } + else while (i < ny) { + num += zds[i]; + if (num < 0) {zds[i++] = num + BIGRAD; num = -1;} + else {zds[i++] = BIGLO(num); num = 0;} + } + } else { + do { + num += (long) zds[i] + x[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + } while (i < nx); + if (!num) return z; + while (i < ny) { + num += zds[i]; + zds[i++] = BIGLO(num); + num = BIGDN(num); + if (!num) return z; + } + if (num) {z = adjbig(z, ny+1); BDIGITS(z)[ny] = num; return z;} + } + return normbig(z); +} + +SCM mulbig(x, nx, y, ny, sgn) + BIGDIG *x, *y; + sizet nx, ny; + int sgn; +{ + sizet i = 0, j = nx + ny; + unsigned long n = 0; + SCM z = mkbig(j, sgn); + BIGDIG *zds = 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++] = BIGLO(n); + n = BIGDN(n); + } while (j < ny); + if (n) {zds[i + j] = n; n = 0;} + } + } while (++i < nx); + return normbig(z); +} +unsigned int divbigdig(ds, h, div) + BIGDIG *ds; + sizet h; + BIGDIG div; +{ + register unsigned long t2 = 0; + while(h--) { + t2 = BIGUP(t2) + ds[h]; + ds[h] = t2 / div; + t2 %= div; + } + return t2; +} +SCM divbigint(x, z, sgn, mode) + SCM x; + long z; + int sgn, mode; +{ + if (z < 0) z = -z; + if (z < BIGRAD) { + register unsigned long t2 = 0; + register BIGDIG *ds = BDIGITS(x); + sizet nd = NUMDIGS(x); + while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z; + if (mode && t2) t2 = z - t2; + return MAKINUM(sgn ? -t2 : t2); + } + { +# ifndef DIGSTOOBIG + unsigned long t2 = pseudolong(z); + return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&t2, + DIGSPERLONG, sgn, mode); +# else + BIGDIG t2[DIGSPERLONG]; + longdigs(z, t2); + return divbigbig(BDIGITS(x), NUMDIGS(x), t2, DIGSPERLONG, sgn, mode); +# endif + } +} +SCM divbigbig(x, nx, y, ny, sgn, modes) + BIGDIG *x, *y; + sizet nx, ny; + int sgn, modes; + /* modes description + 0 remainder + 1 modulo + 2 quotient + 3 quotient but returns 0 if division is not exact. */ +{ + sizet i = 0, j = 0; + long num = 0; + unsigned long t2 = 0; + SCM z, newy; + BIGDIG d = 0, qhat, *zds, *yds; + /* algorithm requires nx >= ny */ + if (nx < ny) + switch (modes) { + case 0: /* remainder -- just return x */ + z = mkbig(nx, sgn); zds = BDIGITS(z); + do {zds[i] = x[i];} while (++i < nx); + return z; + case 1: /* modulo -- return y-x */ + z = mkbig(ny, sgn); zds = BDIGITS(z); + do { + num += (long) y[i] - x[i]; + if (num < 0) {zds[i] = num + BIGRAD; num = -1;} + else {zds[i] = num; num = 0;} + } while (++i < nx); + while (i < ny) { + num += y[i]; + if (num < 0) {zds[i++] = num + BIGRAD; num = -1;} + else {zds[i++] = num; num = 0;} + } + goto doadj; + case 2: return INUM0; /* quotient is zero */ + case 3: return 0; /* the division is not exact */ + } + + z = mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = 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] < (BIGRAD>>1)) { /* normalize operands */ + d = BIGRAD/(y[ny-1]+1); + newy = mkbig(ny, 0); yds = BDIGITS(newy); + while(j < ny) + {t2 += (unsigned long) y[j]*d; yds[j++] = BIGLO(t2); t2 = BIGDN(t2);} + y = yds; j = 0; t2 = 0; + while(j < nx) + {t2 += (unsigned long) x[j]*d; zds[j++] = BIGLO(t2); t2 = 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 = BIGRAD-1; + else qhat = (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] - BIGLO(t2); + if (num < 0) {zds[j - ny + i] = num + BIGRAD; num = -1;} + else {zds[j - ny + i] = num; num = 0;} + t2 = 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] = BIGLO(num); + num = 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 modulo */ + i = 0; num = 0; j = 0; + do {num += y[i] - zds[i]; + j = j | zds[i]; + if (num < 0) {zds[i] = num + BIGRAD; num = -1;} + else {zds[i] = num; num = 0;} + } while (++i < ny); + if (!j) return INUM0; + case 0: /* just normalize remainder */ + if (d) divbigdig(zds, ny, d); + } + doadj: + for(j = ny;j && !zds[j-1];--j) ; + if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT) + if INUMP(z = big2inum(z, j)) return z; + return adjbig(z, j); +} +#endif + +static 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}}; + +static iproc subr1s[] = { + {"not", lnot}, + {"boolean?", booleanp}, + {"pair?", consp}, + {"null?", nullp}, + {"list?", listp}, + {s_length, length}, + {s_reverse, reverse}, + {"symbol?", symbolp}, + {s_symbol2string, symbol2string}, + {s_str2symbol, string2symbol}, + {s_exactp, exactp}, + {s_oddp, oddp}, + {s_evenp, evenp}, + {s_abs, absval}, + {s_lognot, scm_lognot}, + {s_logcount, scm_logcount}, + {s_intlength, scm_intlength}, + {"char?", charp}, + {s_ch_alphap, char_alphap}, + {s_ch_nump, char_nump}, + {s_ch_whitep, char_whitep}, + {s_ch_upperp, char_upperp}, + {s_ch_lowerp, char_lowerp}, + {s_char2int, char2int}, + {s_int2char, int2char}, + {s_ch_upcase, char_upcase}, + {s_ch_downcase, char_downcase}, + {"string?", stringp}, + {s_st_length, st_length}, + {"vector?", vectorp}, + {s_ve_length, vector_length}, + {"procedure?", procedurep}, + {0, 0}}; + +static char s_acons[] = "acons"; +static iproc subr2s[] = { + {&s_acons[1], cons}, + {s_setcar, setcar}, + {s_setcdr, setcdr}, + {s_list_ref, list_ref}, + {s_memq, memq}, + {s_member, member}, + {s_assq, assq}, + {s_assoc, assoc}, + {s_quotient, lquotient}, + {s_remainder, lremainder}, + {s_modulo, modulo}, + {s_logtest, scm_logtest}, + {s_logbitp, scm_logbitp}, + {s_ash, scm_ash}, + {s_intexpt, scm_intexpt}, + {s_st_ref, st_ref}, + {"string<=?", st_leqp}, + {"string-ci<=?", stci_leqp}, + {s_ve_ref, vector_ref}, + {0, 0}}; + +static iproc lsubrs[] = { + {s_list, list}, + {s_append, append}, + {s_string, string}, + {s_st_append, st_append}, + {s_vector, vector}, + {0, 0}}; + +static iproc subr2os[] = { + {s_make_string, make_string}, + {s_make_vector, make_vector}, + {0, 0}}; + +static iproc asubrs[] = { + {s_gcd, lgcd}, + {"lcm", llcm}, + {s_logand, scm_logand}, + {s_logior, scm_logior}, + {s_logxor, scm_logxor}, + {0, 0}}; + +static iproc rpsubrs[] = { + {"eq?", eq}, + {"equal?", equal}, + {"char=?", eq}, + {s_ch_lessp, char_lessp}, + {s_ci_eq, chci_eq}, + {s_ci_lessp, chci_lessp}, + {s_ch_leqp, char_leqp}, + {s_ci_leqp, chci_leqp}, + {s_ch_grp, char_grp}, + {s_ci_grp, chci_grp}, + {s_ch_geqp, char_geqp}, + {s_ci_geqp, chci_geqp}, + + {s_st_equal, st_equal}, + {s_stci_equal, stci_equal}, + {s_st_lessp, st_lessp}, + {s_stci_lessp, stci_lessp}, + {"string>?", st_grp}, + {"string-ci>?", stci_grp}, + {"string>=?", st_geqp}, + {"string-ci>=?", stci_geqp}, + {0, 0}}; + +static iproc subr3s[] = { + {s_bitextract, scm_bitextract}, + {s_substring, substring}, + {s_acons, acons}, + {s_st_set, st_set}, + {s_ve_set, vector_set}, + {0, 0}}; + +void init_iprocs(subra, type) + iproc *subra; + int type; +{ + for(;subra->string; subra++) + make_subr(subra->string, + type, + subra->cproc); +} + +void init_subrs() +{ + init_iprocs(cxrs, tc7_cxr); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(rpsubrs, tc7_rpsubr); + init_iprocs(lsubrs, tc7_lsubr); + init_iprocs(asubrs, tc7_asubr); + init_iprocs(subr3s, tc7_subr_3); +} @@ -0,0 +1,1758 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "sys.c" opening and closing files, storage, and GC. */ + +#include <ctype.h> + +#include "scm.h" +#include "setjump.h" +void igc P((char *what, STACKITEM *stackbase)); + +/* ttyname() etc. should be defined in <unistd.h>. But unistd.h is + missing on many systems. */ + +#ifndef STDC_HEADERS + char *ttyname P((int fd)); + char *tmpnam P((char *s)); + sizet fwrite (); +# ifdef sun +# ifndef __svr4__ + int fputs P((char *s, FILE* stream)); + int fputc P((char c, FILE* stream)); + int fflush P((FILE* stream)); +# endif +# endif + int fgetc P((FILE* stream)); + int fclose P((FILE* stream)); + int pclose P((FILE* stream)); + int unlink P((const char *pathname)); + char *mktemp P((char *template)); +#endif + +static void gc_sweep P((void)); + +char s_nogrow[] = "could not grow", s_heap[] = "heap", + s_hplims[] = "hplims"; +static char s_input_portp[] = "input-port?", + s_output_portp[] = "output-port?"; +static char s_open_file[] = "open-file"; +char s_close_port[] = "close-port"; + +#ifdef __IBMC__ +# include <io.h> +# include <direct.h> +# define ttyname(x) "CON:" +#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 /* __IBMC__ */ +SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ + SCM port; +{ +#ifndef NOSETBUF +# ifndef MSDOS +# ifdef FIONREAD +# ifndef ultrix + SYSCALL(setbuf(STREAM(port), 0);); +# endif +# endif +# endif +#endif + return UNSPECIFIED; +} + +long mode_bits(modes) + char *modes; +{ + return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0) + | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0) + | (strchr(modes, '0') ? BUF0 : 0); +} + +SCM open_file(filename, modes) + SCM filename, modes; +{ + register SCM port; + FILE *f; + ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); + ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file); + NEWCELL(port); + DEFER_INTS; + SYSCALL(f = fopen(CHARS(filename), CHARS(modes));); + if (!f) port = BOOL_F; + else { + SETSTREAM(port, f); + if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes)))) + i_setbuf0(port); + ALLOW_INTS; + } + return port; +} + +SCM close_port(port) + SCM port; +{ + sizet i; + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port); + if CLOSEDP(port) return UNSPECIFIED; + i = PTOBNUM(port); + DEFER_INTS; + if (ptobs[i].fclose) { + SYSCALL((ptobs[i].fclose)(STREAM(port));); + } + CAR(port) &= ~OPN; + ALLOW_INTS; + return UNSPECIFIED; +} +SCM input_portp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return INPORTP(x) ? BOOL_T : BOOL_F; +} +SCM output_portp(x) + SCM x; +{ + if IMP(x) return BOOL_F; + return OUTPORTP(x) ? BOOL_T : BOOL_F; +} + +#if (__TURBOC__==1) +# undef L_tmpnam /* Not supported in TURBOC V1.0 */ +#endif +#ifdef GO32 +# undef L_tmpnam +#endif +#ifdef MWC +# undef L_tmpnam +#endif + +#ifdef L_tmpnam +SCM ltmpnam() +{ + char name[L_tmpnam]; + SYSCALL(tmpnam(name);); + return makfrom0str(name); +} +#else +/* TEMPTEMPLATE is used only if mktemp() is being used instead of + tmpnam(). */ + +# ifdef AMIGA +# define TEMPTEMPLATE "T:SchemeaaaXXXXXX"; +# else +# ifdef vms +# define TEMPTEMPLATE "sys$scratch:aaaXXXXXX"; +# else /* vms */ +# ifdef __MSDOS__ +# ifdef GO32 +# define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX"; +# else +# define TEMPTEMPLATE "TMPaaaXXXXXX"; +# endif +# else /* __MSDOS__ */ +# define TEMPTEMPLATE "/tmp/aaaXXXXXX"; +# endif /* __MSDOS__ */ +# endif /* vms */ +# endif /* AMIGA */ + +char template[] = TEMPTEMPLATE; +# define TEMPLEN (sizeof template/sizeof(char) - 1) +SCM ltmpnam() +{ + SCM name; + int temppos = TEMPLEN-9; + name = makfromstr(template, (sizet)TEMPLEN); + DEFER_INTS; +inclp: + template[temppos]++; + if (!isalpha(template[temppos])) { + template[temppos++] = 'a'; + goto inclp; + } +# ifndef AMIGA +# ifndef __MSDOS__ + SYSCALL(temppos = !*mktemp(CHARS(name));); + if (temppos) name = BOOL_F; +# endif +# endif + ALLOW_INTS; + return name; +} +#endif /* L_tmpnam */ + +#ifdef M_SYSV +# define remove unlink +#endif +static char s_del_fil[] = "delete-file"; +SCM del_fil(str) + SCM str; +{ + int ans; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil); +#ifdef STDC_HEADERS + SYSCALL(ans = remove(CHARS(str));); +#else + SYSCALL(ans = unlink(CHARS(str));); +#endif + return ans ? BOOL_F : BOOL_T; +} + +void prinport(exp, port, type) + SCM exp; SCM port; char *type; +{ + lputs("#<", port); + if CLOSEDP(exp) lputs("closed-", port); + else { + if (RDNG & CAR(exp)) lputs("input-", port); + if (WRTNG & CAR(exp)) lputs("output-", port); + } + lputs(type, port); + lputc(' ', port); +#ifndef MSDOS +# ifndef __EMX__ +# ifndef _DCC +# ifndef AMIGA +# ifndef THINK_C + if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp)))) + lputs(ttyname(fileno(STREAM(exp))), port); + else +# endif +# endif +# endif +# endif +#endif + if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port); + else intprint(CDR(exp), 16, port); + lputc('>', port); +} +static int prinfport(exp, port, writing) + SCM exp; SCM port; int writing; +{ + prinport(exp, port, s_port_type); + return !0; +} +static int prinstpt(exp, port, writing) + SCM exp; SCM port; int writing; +{ + prinport(exp, port, s_string); + return !0; +} +static int prinsfpt(exp, port, writing) + SCM exp; SCM port; int writing; +{ + prinport(exp, port, "soft"); + return !0; +} + +static int stputc(c, p) + int c; SCM p; +{ + sizet ind = INUM(CAR(p)); + if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1))); + CHARS(CDR(p))[ind] = c; + CAR(p) = MAKINUM(ind + 1); + return c; +} +sizet stwrite(str, siz, num, p) + sizet siz, num; + char *str; SCM p; +{ + sizet ind = INUM(CAR(p)); + sizet len = siz * num; + char *dst; + if (ind + len >= LENGTH(CDR(p))) + resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1))); + dst = &(CHARS(CDR(p))[ind]); + while (len--) dst[len] = str[len]; + CAR(p) = MAKINUM(ind + siz*num); + return num; +} +static int stputs(s, p) + char *s; SCM p; +{ + stwrite(s, 1, strlen(s), p); + return 0; +} +static int stgetc(p) + SCM p; +{ + sizet ind = INUM(CAR(p)); + if (ind >= LENGTH(CDR(p))) return EOF; + CAR(p) = MAKINUM(ind + 1); + return CHARS(CDR(p))[ind]; +} +int noop0(stream) + FILE *stream; +{ + return 0; +} +SCM mkstrport(pos, str, modes, caller) + SCM pos; + SCM str; + long modes; + char *caller; +{ + SCM z; + ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller); + ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller); + str = cons(pos, str); + NEWCELL(z); + DEFER_INTS; + SETCHARS(z, str); + CAR(z) = tc16_strport | modes; + ALLOW_INTS; + return z; +} +static char s_cwos[] = "call-with-output-string"; +static char s_cwis[] = "call-with-input-string"; +SCM cwos(proc) + SCM proc; +{ + SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED), + OPN | WRTNG, + s_cwos); + apply(proc, p, listofnull); + return resizuve(CDR(CDR(p)), CAR(CDR(p))); +} +SCM cwis(str, proc) + SCM str, proc; +{ + SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis); + return apply(proc, p, listofnull); +} +#ifdef vms +sizet pwrite(ptr, size, nitems, port) + char *ptr; + sizet size, nitems; + FILE* port; +{ + sizet len = size * nitems; + sizet i = 0; + for(;i < len;i++) putc(ptr[i], port); + return len; +} +# define ffwrite pwrite +#else +# define ffwrite fwrite +#endif + +static ptobfuns fptob = { + mark0, + fclose, + prinfport, + 0, + fputc, + fputs, + ffwrite, + fflush, + fgetc, + fclose}; +ptobfuns pipob = { + mark0, + 0, /* replaced by pclose in init_ioext() */ + 0, /* replaced by prinpipe in init_ioext() */ + 0, + fputc, + fputs, + ffwrite, + fflush, + fgetc, + 0}; /* replaced by pclose in init_ioext() */ +static ptobfuns stptob = { + markcdr, + noop0, + prinstpt, + 0, + stputc, + stputs, + stwrite, + noop0, + stgetc, + 0}; + + /* Soft ports */ + +/* fputc, fwrite, fputs, and fclose are called within a + SYSCALL. So we need to set errno to 0 before returning. fflush + may be called within a SYSCALL. So we need to set errno to 0 + before returning. */ + +static int sfputc(c, p) + int c; SCM p; +{ + apply(VELTS(p)[0], MAKICHR(c), listofnull); + errno = 0; + return c; +} +sizet sfwrite(str, siz, num, p) + sizet siz, num; + char *str; SCM p; +{ + SCM sstr; + sstr = makfromstr(str, siz * num); + apply(VELTS(p)[1], sstr, listofnull); + errno = 0; + return num; +} +static int sfputs(s, p) + char *s; SCM p; +{ + sfwrite(s, 1, strlen(s), p); + return 0; +} +int sfflush(stream) + SCM stream; +{ + SCM f = VELTS(stream)[2]; + if (BOOL_F==f) return 0; + f = apply(f, EOL, EOL); + errno = 0; + return BOOL_F==f ? EOF : 0; +} +static int sfgetc(p) + SCM p; +{ + SCM ans; + ans = apply(VELTS(p)[3], EOL, EOL); + errno = 0; + if (FALSEP(ans) || EOF_VAL==ans) return EOF; + ASSERT(ICHRP(ans), ans, ARG1, "getc"); + return ICHR(ans); +} +static int sfclose(p) + SCM p; +{ + SCM f = VELTS(p)[4]; + if (BOOL_F==f) return 0; + f = apply(f, EOL, EOL); + errno = 0; + return BOOL_F==f ? EOF : 0; +} +static char s_mksfpt[] = "make-soft-port"; +SCM mksfpt(pv, modes) + SCM pv, modes; +{ + SCM z; + ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt); + ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt); + NEWCELL(z); + DEFER_INTS; + CAR(z) = tc16_sfport | mode_bits(CHARS(modes)); + SETSTREAM(z, pv); + ALLOW_INTS; + return z; +} + +static ptobfuns sfptob = { + markcdr, + noop0, + prinsfpt, + 0, + sfputc, + sfputs, + sfwrite, + sfflush, + sfgetc, + sfclose}; + +static smobfuns freecell = { + mark0, + free0, + 0, + 0}; +static smobfuns flob = { + mark0, + /*flofree*/0, + floprint, + floequal}; +static smobfuns bigob = { + mark0, + /*bigfree*/0, + bigprint, + bigequal}; +void (**finals)() = 0; +sizet num_finals = 0; +static char s_final[] = "final"; + +void init_types() +{ + numptob = 0; + ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns)); + /* These newptob calls must be done in this order */ + /* tc16_fport = */ newptob(&fptob); + /* tc16_pipe = */ newptob(&pipob); + /* tc16_strport = */ newptob(&stptob); + /* tc16_sfport = */ newptob(&sfptob); + numsmob = 0; + smobs = (smobfuns *)malloc(7*sizeof(smobfuns)); + /* These newsmob calls must be done in this order */ + newsmob(&freecell); + newsmob(&flob); + newsmob(&bigob); + newsmob(&bigob); + finals = (void(**)())malloc(2 * sizeof(finals[0])); + num_finals = 0; +} + +void add_final(final) + void (* final)(); +{ + DEFER_INTS; + finals = (void (**)()) must_realloc((char *)finals, + 1L*(num_finals)*sizeof(finals[0]), + (1L+num_finals)*sizeof(finals[0]), + s_final); + finals[num_finals++] = final; + ALLOW_INTS; + return; +} + +char s_obunhash[] = "object-unhash"; +static iproc subr0s[] = { + {"gc", gc}, + {"tmpnam", ltmpnam}, + {0, 0}}; + +static iproc subr1s[] = { + {s_input_portp, input_portp}, + {s_output_portp, output_portp}, + {s_close_port, close_port}, + {"eof-object?", eof_objectp}, + {s_cwos, cwos}, + {"object-hash", obhash}, + {s_obunhash, obunhash}, + {s_del_fil, del_fil}, + {0, 0}}; + +static iproc subr2s[] = { + {s_open_file, open_file}, + {s_cwis, cwis}, + {s_mksfpt, mksfpt}, + {0, 0}}; + +SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3)); +void init_io(){ + make_subr("dynamic-wind", tc7_subr_3, dynwind); + init_iprocs(subr0s, tc7_subr_0); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2s, tc7_subr_2); +#ifndef CHEAP_CONTINUATIONS + add_feature("full-continuation"); +#endif +} + +void grew_lim(nm) + long nm; +{ + ALLOW_INTS; + growth_mon(s_limit, nm, "bytes"); + DEFER_INTS; +} +int expmem = 0; +sizet hplim_ind = 0; +long heap_size = 0; +CELLPTR *hplims, heap_org; +SCM freelist = EOL; +long mtrigger; +char *must_malloc(len, what) + long len; + char *what; +{ + char *ptr; + sizet size = len; + long nm = mallocated+size; + if (len != size) +malerr: + wta(MAKINUM(len), (char *)NALLOC, what); + if ((nm <= mtrigger)) { + SYSCALL(ptr = (char *)malloc(size);); + if (NULL != ptr) {mallocated = nm; return ptr;} + } + igc(what, CONT(rootcont)->stkbse); + nm = mallocated+size; + if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before malloc */ + SYSCALL(ptr = (char *)malloc(size);); + if (NULL != ptr) { + mallocated = nm; + if (nm > mtrigger) mtrigger = nm + nm/2; + return ptr;} + goto malerr; +} +char *must_realloc(where, olen, len, what) + char *where; + long olen, len; + char *what; +{ + char *ptr; + sizet size = len; + long nm = mallocated+size-olen; + if (len != size) +ralerr: + wta(MAKINUM(len), (char *)NALLOC, what); + if ((nm <= mtrigger)) { + SYSCALL(ptr = (char *)realloc(where, size);); + if (NULL != ptr) {mallocated = nm; return ptr;} + } + igc(what, CONT(rootcont)->stkbse); + nm = mallocated+size-olen; + if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before realloc */ + SYSCALL(ptr = (char *)realloc(where, size);); + if (NULL != ptr) { + mallocated = nm; + if (nm > mtrigger) mtrigger = nm + nm/2; + return ptr;} + goto ralerr; +} +void must_free(obj) + char *obj; +{ + if (obj) free(obj); + else wta(INUM0, "already free", ""); +} + +SCM symhash; /* This used to be a sys_protect, but + Radey Shouman <shouman@zianet.com> + added GC for unuesd, UNDEFINED + symbols.*/ +int symhash_dim = NUM_HASH_BUCKETS; +/* sym2vcell looks up the symbol in the symhash table. */ +SCM sym2vcell(sym) + SCM sym; +{ + SCM lsym, z; + sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym), + (unsigned long)symhash_dim); + for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + z = CAR(lsym); + if (CAR(z)==sym) return z; + } + wta(sym, "uninterned symbol? ", ""); +} +/* intern() and sysintern() return a pair; + CAR is the symbol, CDR is the value. */ +SCM intern(name, len) + char *name; + sizet len; +{ + SCM lsym, z; + register sizet i = len; + register unsigned char *tmp = (unsigned char *)name; + sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); + for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + z = CAR(lsym); + z = CAR(z); + tmp = UCHARS(z); + if (LENGTH(z) != len) goto trynext; + for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; + return CAR(lsym); + trynext: ; + } + lsym = makfromstr(name, len); + DEFER_INTS; + SETLENGTH(lsym, (long)len, tc7_msymbol); + ALLOW_INTS; + z = acons(lsym, UNDEFINED, UNDEFINED); + DEFER_INTS; /* Operations on symhash must be atomic. */ + CDR(z) = VELTS(symhash)[hash]; + VELTS(symhash)[hash] = z; + z = CAR(z); + ALLOW_INTS; + return z; +} +SCM sysintern(name, val) + char *name; + SCM val; +{ + SCM lsym, z; + sizet len = strlen(name); + register sizet i = len; + register unsigned char *tmp = (unsigned char *)name; + sizet hash = strhash(tmp, i, (unsigned long)symhash_dim); + for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) { + z = CAR(lsym); + z = CAR(z); + tmp = UCHARS(z); + if (LENGTH(z) != len) goto trynext; + for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext; + lsym = CAR(lsym); + CDR(lsym) = val; + return lsym; + trynext: ; + } + NEWCELL(lsym); + SETLENGTH(lsym, (long)len, tc7_ssymbol); + SETCHARS(lsym, name); + lsym = cons(lsym, val); + z = cons(lsym, UNDEFINED); + CDR(z) = VELTS(symhash)[hash]; + VELTS(symhash)[hash] = z; + return lsym; +} +SCM cons(x, y) + SCM x, y; +{ + register SCM z; + NEWCELL(z); + CAR(z) = x; + CDR(z) = y; + return z; +} +SCM cons2(w, x, y) + SCM w, x, y; +{ + register SCM z; + NEWCELL(z); + CAR(z) = x; + CDR(z) = y; + x = z; + NEWCELL(z); + CAR(z) = w; + CDR(z) = x; + return z; +} +SCM acons(w, x, y) + SCM w, x, y; +{ + register SCM z; + NEWCELL(z); + CAR(z) = w; + CDR(z) = x; + x = z; + NEWCELL(z); + CAR(z) = x; + CDR(z) = y; + return z; +} + +SCM makstr(len) + long len; +{ + SCM s; + NEWCELL(s); + DEFER_INTS; + SETCHARS(s, must_malloc(len+1, s_string)); + SETLENGTH(s, len, tc7_string); + ALLOW_INTS; + CHARS(s)[len] = 0; + return s; +} + +SCM make_subr(name, type, fcn) + char *name; + int type; + SCM (*fcn)(); +{ + SCM symcell = sysintern(name, UNDEFINED); + long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8); + register SCM z; + if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org)) + tmp = 0; + NEWCELL(z); + SUBRF(z) = fcn; + CAR(z) = tmp + type; + CDR(symcell) = z; + return z; +} + +#ifdef CCLO +SCM makcclo(proc, len) + SCM proc; + long len; +{ + SCM s; + NEWCELL(s); + DEFER_INTS; + SETCHARS(s, must_malloc(len*sizeof(SCM), "compiled-closure")); + SETLENGTH(s, len, tc7_cclo); + while (--len) VELTS(s)[len] = UNSPECIFIED; + CCLO_SUBR(s) = proc; + ALLOW_INTS; + return s; +} +#endif + +#ifdef STACK_LIMIT +void stack_check() +{ + STACKITEM *start = CONT(rootcont)->stkbse; + STACKITEM stack; +# ifdef STACK_GROWS_UP + if (&stack - start > STACK_LIMIT/sizeof(STACKITEM)) +# else + if (start - &stack > STACK_LIMIT/sizeof(STACKITEM)) +# endif /* def STACK_GROWS_UP */ + wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack"); +} +#endif +void stack_report() +{ + STACKITEM stack; + intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 16, cur_errp); + lputs(" of stack: 0x", cur_errp); + intprint((long)CONT(rootcont)->stkbse, 16, cur_errp); + lputs(" - 0x", cur_errp); + intprint((long)&stack, 16, cur_errp); + lputs("\n", cur_errp); +} + +SCM dynwind(thunk1, thunk2, thunk3) + SCM thunk1, thunk2, thunk3; +{ + SCM ans; + apply(thunk1, EOL, EOL); + dynwinds = acons(thunk1, thunk3, dynwinds); + ans = apply(thunk2, EOL, EOL); + dynwinds = CDR(dynwinds); + apply(thunk3, EOL, EOL); + return ans; +} +void dowinds(to, delta) + SCM to; + long delta; +{ + tail: + if (dynwinds==to); + else if (0 > delta) { + dowinds(CDR(to), 1+delta); + apply(CAR(CAR(to)), EOL, EOL); + dynwinds = to; + } + else { + SCM from = CDR(CAR(dynwinds)); + dynwinds = CDR(dynwinds); + apply(from, EOL, EOL); + delta--; goto tail; /* dowinds(to, delta-1); */ + } +} + +/* Remember that setjmp needs to be called after scm_make_cont */ + +SCM scm_make_cont() +{ + SCM cont; + CONTINUATION *ncont; + NEWCELL(cont); + DEFER_INTS; + ncont = make_continuation(CONT(rootcont)); + if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont); + ncont->other.parent = rootcont; + SETCONT(cont, ncont); + SETLENGTH(cont, ncont->length, tc7_contin); + ncont->other.dynenv = dynwinds; +#ifdef CAUTIOUS + CONT(cont)->other.stack_trace = stacktrace; +#endif + ALLOW_INTS; + return cont; +} +static char s_sstale[] = "strangely stale"; +void scm_dynthrow(cont, val) + CONTINUATION *cont; + SCM val; +{ + if (cont->stkbse != CONT(rootcont)->stkbse) + wta(cont->other.dynenv, &s_sstale[10], s_cont); + dowinds(cont->other.dynenv, + ilength(dynwinds)-ilength(cont->other.dynenv)); +#ifdef CAUTIOUS + stacktrace = cont->other.stack_trace; +#endif + throw_to_continuation(cont, val, CONT(rootcont)); + wta(cont->other.dynenv, s_sstale, s_cont); +} + +SCM obhash(obj) + SCM obj; +{ + +#ifdef BIGDIG + long n = SRS(obj, 1); + if (!FIXABLE(n)) return long2big(n); +#endif + return (obj<<1)+2L; +} + +SCM obunhash(obj) + SCM obj; +{ +#ifdef BIGDIG + if (NIMP(obj) && BIGP(obj)) { + sizet i = NUMDIGS(obj); + BIGDIG *ds = BDIGITS(obj); + if (TYP16(obj)==tc16_bigpos) { + obj = 0; + while (i--) obj = BIGUP(obj) + ds[i]; + } + else { + obj = 0; + while (i--) obj = BIGUP(obj) - ds[i]; + } + obj <<= 1; + goto comm; + } +#endif + ASSERT(INUMP(obj), obj, ARG1, s_obunhash); + obj = SRS(obj, 1) & ~1L; + comm: + if IMP(obj) return obj; + if NCELLP(obj) return BOOL_F; + { /* code is adapted from mark_locations */ + register CELLPTR ptr = (CELLPTR)SCM2PTR(obj); + register sizet i = 0, j = hplim_ind; + do { + if PTR_GT(hplims[i++], ptr) break; + if PTR_LE(hplims[--j], ptr) break; + if ((i != j) + && PTR_LE(hplims[i++], ptr) + && PTR_GT(hplims[--j], ptr)) continue; + if NFREEP(obj) return obj; + break; + } while(i<j); + } + return BOOL_F; +} + +unsigned long strhash(str, len, n) + unsigned char *str; + sizet len; + unsigned long n; +{ + if (len>5) + { + sizet i = 5; + unsigned long h = 264 % n; + while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n; + return h; + } + else { + sizet i = len; + unsigned long h = 0; + while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n; + return h; + } +} + +static void fixconfig(s1, s2, s) + char *s1, *s2; + int s; +{ + fputs(s1, stderr); + fputs(s2, stderr); + fputs("\nin ", stderr); + fputs(s ? "setjump" : "scmfig", stderr); + fputs(".h and recompile scm\n", stderr); + quit(MAKINUM(1L)); +} + +sizet init_heap_seg(seg_org, size) + CELLPTR seg_org; + sizet size; +{ + register CELLPTR ptr = seg_org; +#ifdef POINTERS_MUNGED + register SCM scmptr; +#else +# define scmptr ptr +#endif + CELLPTR seg_end = CELL_DN((char *)ptr + size); + sizet i = hplim_ind, ni = 0; + if (ptr==NULL) return 0; + while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++; + while(i-- > ni) hplims[i+2] = hplims[i]; + hplim_ind += 2; + hplims[ni++] = ptr; /* same as seg_org here */ + hplims[ni++] = seg_end; + ptr = CELL_UP(ptr); + ni = seg_end - ptr; + for (i = ni;i--;ptr++) { +#ifdef POINTERS_MUNGED + scmptr = PTR2SCM(ptr); +#endif + CAR(scmptr) = (SCM)tc_free_cell; + CDR(scmptr) = PTR2SCM(ptr+1); + } +/* CDR(scmptr) = freelist; */ + CDR(PTR2SCM(--ptr)) = freelist; + freelist = PTR2SCM(CELL_UP(seg_org)); + heap_size += ni; + return size; +#ifdef scmptr +# undef scmptr +#endif +} +static void alloc_some_heap() +{ + CELLPTR ptr, *tmplims; + sizet len = (2+hplim_ind)*sizeof(CELLPTR); + ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims); + if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap); + SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); + if (!tmplims) +badhplims: + wta(UNDEFINED, s_nogrow, s_hplims); + else hplims = tmplims; + /* hplim_ind gets incremented in init_heap_seg() */ + if (expmem) { + len = (sizet)(EXPHEAP(heap_size)*sizeof(cell)); + if ((sizet)(EXPHEAP(heap_size)*sizeof(cell)) != len) len = 0; + } + else len = HEAP_SEG_SIZE; + while (len >= MIN_HEAP_SEG_SIZE) { + SYSCALL(ptr = (CELLPTR) malloc(len);); + if (ptr) { + init_heap_seg(ptr, len); + return; + } + len /= 2; + } + wta(UNDEFINED, s_nogrow, s_heap); +} + +smobfuns *smobs; +sizet numsmob; +long newsmob(smob) + smobfuns *smob; +{ + char *tmp; + if (255 <= numsmob) goto smoberr; + DEFER_INTS; + SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns));); + if (tmp) { + smobs = (smobfuns *)tmp; + smobs[numsmob].mark = smob->mark; + smobs[numsmob].free = smob->free; + smobs[numsmob].print = smob->print; + smobs[numsmob].equalp = smob->equalp; + numsmob++; + } + ALLOW_INTS; + if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob"); + return tc7_smob + (numsmob-1)*256; +} +ptobfuns *ptobs; +sizet numptob; +long newptob(ptob) + ptobfuns *ptob; +{ + char *tmp; + if (255 <= numptob) goto ptoberr; + DEFER_INTS; + SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns));); + if (tmp) { + ptobs = (ptobfuns *)tmp; + ptobs[numptob].mark = ptob->mark; + ptobs[numptob].free = ptob->free; + ptobs[numptob].print = ptob->print; + ptobs[numptob].equalp = ptob->equalp; + ptobs[numptob].fputc = ptob->fputc; + ptobs[numptob].fputs = ptob->fputs; + ptobs[numptob].fwrite = ptob->fwrite; + ptobs[numptob].fflush = ptob->fflush; + ptobs[numptob].fgetc = ptob->fgetc; + ptobs[numptob].fclose = ptob->fclose; + numptob++; + } + ALLOW_INTS; + if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob"); + return tc7_port + (numptob-1)*256; +} +SCM markcdr(ptr) + SCM ptr; +{ + if GC8MARKP(ptr) return BOOL_F; + SETGC8MARK(ptr); + return CDR(ptr); +} +SCM mark0(ptr) + SCM ptr; +{ + SETGC8MARK(ptr); + return BOOL_F; +} +sizet free0(ptr) + CELLPTR ptr; +{ + return 0; +} +SCM equal0(ptr1, ptr2) + SCM ptr1, ptr2; +{ + return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F; +} + +/* statically allocated port for diagnostic messages */ +cell tmp_errp = {(SCM)((0L<<8)|tc16_fport|OPN|WRTNG), 0}; + +static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; +extern sizet num_protects; /* sys_protects now in scl.c */ +void init_storage(stack_start_ptr, init_heap_size) + STACKITEM *stack_start_ptr; + long init_heap_size; +{ + sizet j = num_protects; + /* Because not all protects may get initialized */ + while(j) sys_protects[--j] = BOOL_F; + tmp_errp.cdr = (SCM)stderr; + cur_errp = PTR2SCM(&tmp_errp); + freelist = EOL; + expmem = 0; + +#ifdef SHORT_INT + if (sizeof(int) >= sizeof(long)) + fixconfig(remsg, "SHORT_INT", 1); +#else + if (sizeof(int) < sizeof(long)) + fixconfig(addmsg, "SHORT_INT", 1); +#endif +#ifdef CDR_DOUBLES + if (sizeof(double) != sizeof(long)) + fixconfig(remsg, "CDR_DOUBLES", 0); +#else +# ifdef SINGLES + if (sizeof(float) != sizeof(long)) + if (sizeof(double) == sizeof(long)) + fixconfig(addmsg, "CDR_DOUBLES", 0); + else + fixconfig(remsg, "SINGLES", 0); +# endif +#endif +#ifdef BIGDIG + if (2*BITSPERDIG/CHAR_BIT > sizeof(long)) + fixconfig(remsg, "BIGDIG", 0); +# ifndef DIGSTOOBIG + if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long)) + fixconfig(addmsg, "DIGSTOOBIG", 0); +# endif +#endif +#ifdef STACK_GROWS_UP + if (((STACKITEM *)&j - stack_start_ptr) < 0) + fixconfig(remsg, "STACK_GROWS_UP", 1); +#else + if ((stack_start_ptr - (STACKITEM *)&j) < 0) + fixconfig(addmsg, "STACK_GROWS_UP", 1); +#endif + j = HEAP_SEG_SIZE; + if (HEAP_SEG_SIZE != j) + fixconfig("reduce", "size of HEAP_SEG_SIZE", 0); + + mtrigger = INIT_MALLOC_LIMIT; + hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims); + if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE; + j = init_heap_size; + if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) { + j = HEAP_SEG_SIZE; + if (!init_heap_seg((CELLPTR) malloc(j), j)) + wta(MAKINUM(j), (char *)NALLOC, s_heap); + } + else expmem = 1; + heap_org = CELL_UP(hplims[0]); + /* hplims[0] can change. do not remove heap_org */ + + NEWCELL(def_inp); + CAR(def_inp) = (tc16_fport|OPN|RDNG); + SETSTREAM(def_inp, stdin); + NEWCELL(def_outp); + CAR(def_outp) = (tc16_fport|OPN|WRTNG); + SETSTREAM(def_outp, stdout); + NEWCELL(def_errp); + CAR(def_errp) = (tc16_fport|OPN|WRTNG); + SETSTREAM(def_errp, stderr); + cur_inp = def_inp; + cur_outp = def_outp; + cur_errp = def_errp; + dynwinds = EOL; + NEWCELL(rootcont); + SETCONT(rootcont, make_root_continuation(stack_start_ptr)); + CAR(rootcont) = tc7_contin; + CONT(rootcont)->other.dynenv = EOL; + CONT(rootcont)->other.parent = BOOL_F; + stacktrace = EOL; +#ifdef CAUTIOUS + CONT(rootcont)->other.stack_trace = EOL; +#endif + listofnull = cons(EOL, EOL); + undefineds = cons(UNDEFINED, EOL); + CDR(undefineds) = undefineds; + nullstr = makstr(0L); + nullvect = make_vector(INUM0, UNDEFINED); + /* NEWCELL(nullvect); + CAR(nullvect) = tc7_vector; + SETCHARS(nullvect, NULL); */ + symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL); + sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); + sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); +#ifdef BIGDIG + sysintern("bignum-radix", MAKINUM(BIGRAD)); +#endif + /* flo0 is now setup in scl.c */ +} + +/* The way of garbage collecting which allows use of the cstack is due to */ +/* Scheme In One Defun, but in C this time. + + * COPYRIGHT (c) 1989 BY * + * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * + * ALL RIGHTS RESERVED * + +Permission to use, copy, modify, distribute and sell this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all copies +and that both that copyright notice and this permission notice appear +in supporting documentation, and that the name of Paradigm Associates +Inc not be used in advertising or publicity pertaining to distribution +of the software without specific, written prior permission. + +PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +SOFTWARE. + +gjc@paradigm.com + +Paradigm Associates Inc Phone: 617-492-6079 +29 Putnam Ave, Suite 6 +Cambridge, MA 02138 +*/ +char s_cells[] = "cells"; +SCM gc_for_newcell() +{ + SCM fl; + DEFER_INTS; + igc(s_cells, CONT(rootcont)->stkbse); + ALLOW_INTS; + if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) { + DEFER_INTS; + alloc_some_heap(); + ALLOW_INTS; + growth_mon("number of heaps", (long)(hplim_ind/2), "segments"); + growth_mon(s_heap, heap_size, s_cells); + } + ++cells_allocated; + fl = freelist; + freelist = CDR(fl); + return fl; +} + +static char s_bad_type[] = "unknown type in "; +jmp_buf save_regs_gc_mark; +void mark_locations P((STACKITEM x[], sizet n)); +static void mark_syms P((SCM v)); +static void mark_sym_values P((SCM v)); +static void sweep_symhash P((SCM v)); + +SCM gc() +{ + DEFER_INTS; + igc("call", CONT(rootcont)->stkbse); + ALLOW_INTS; + return UNSPECIFIED; +} +void igc(what, stackbase) + char *what; + STACKITEM *stackbase; +{ + int j = num_protects; + long oheap_size = heap_size; + gc_start(what); + ++errjmp_bad; + /* By marking symhash first, we provide the best immunity from + accidental references. In order to accidentally protect a + symbol, a pointer will have to point directly at the symbol (as + opposed to the vector or bucket lists). */ + mark_syms(symhash); + /* mark_sym_values() can be called anytime after mark_syms. */ +#ifdef NO_SYM_GC + gc_mark(symhash); +#else + mark_sym_values(symhash); +#endif + if (stackbase) { + FLUSH_REGISTER_WINDOWS; + /* This assumes that all registers are saved into the jmp_buf */ + setjmp(save_regs_gc_mark); + mark_locations((STACKITEM *) save_regs_gc_mark, + (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) / + sizeof(STACKITEM)); + { + /* stack_len is long rather than sizet in order to guarantee that + &stack_len is long aligned */ +#ifdef STACK_GROWS_UP +# ifdef nosve + long stack_len = (STACKITEM *)(&stack_len) - stackbase; +# else + long stack_len = stack_size(stackbase); +# endif + mark_locations(stackbase, (sizet)stack_len); +#else +# ifdef nosve + long stack_len = stackbase - (STACKITEM *)(&stack_len); +# else + long stack_len = stack_size(stackbase); +# endif + mark_locations((stackbase - stack_len), (sizet)stack_len); +#endif + } + } + while(j--) gc_mark(sys_protects[j]); + sweep_symhash(symhash); + gc_sweep(); + --errjmp_bad; + gc_end(); + if (oheap_size != heap_size) { + ALLOW_INTS; + growth_mon(s_heap, heap_size, s_cells); + DEFER_INTS; + } +} + +static char s_not_free[] = "not freed"; +void free_storage() +{ + DEFER_INTS; + gc_start("free"); + ++errjmp_bad; + cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = PTR2SCM(&tmp_errp); + gc_mark(def_inp); /* don't want to close stdin */ + gc_mark(def_outp); /* don't want to close stdout */ + gc_mark(def_errp); /* don't want to close stderr */ + gc_sweep(); + rootcont = BOOL_F; + while (hplim_ind) { /* free heap segments */ + hplim_ind -= 2; + { + CELLPTR ptr = CELL_UP(hplims[hplim_ind]); + sizet seg_size = CELL_DN(hplims[hplim_ind+1]) - ptr; + heap_size -= seg_size; + must_free((char *)hplims[hplim_ind]); + hplims[hplim_ind] = 0; + growth_mon(s_heap, heap_size, s_cells); + }} + if (heap_size) wta(MAKINUM(heap_size), s_not_free, s_heap); + if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims); + /* Not all cells get freed (see gc_mark() calls above). */ + /* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */ + /* either there is a small memory leak or I am counting wrong. */ + /* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */ + must_free((char *)hplims); + hplims = 0; + must_free((char *)smobs); + smobs = 0; + gc_end(); + ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ + exit_report(); + must_free((char *)ptobs); + ptobs = 0; + lmallocated = mallocated = 0; + /* Can't do gc_end() here because it uses ptobs which have been freed */ +} + +void gc_mark(p) + SCM p; +{ + register long i; + register SCM ptr = p; + gc_mark_loop: + if IMP(ptr) return; + gc_mark_nimp: + if (NCELLP(ptr) + /* #ifndef RECKLESS + || PTR_GT(hplims[0], (CELLPTR)ptr) + || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) +#endif */ + ) wta(ptr, "rogue pointer in ", s_heap); + switch TYP7(ptr) { + case tcs_cons_nimcar: + if GCMARKP(ptr) break; + SETGCMARK(ptr); + if IMP(CDR(ptr)) { /* IMP works even with a GC mark */ + ptr = CAR(ptr); + goto gc_mark_nimp; + } + gc_mark(CAR(ptr)); + ptr = GCCDR(ptr); + goto gc_mark_nimp; + case tcs_cons_imcar: + case tcs_cons_gloc: + if GCMARKP(ptr) break; + SETGCMARK(ptr); + ptr = GCCDR(ptr); + goto gc_mark_loop; + case tcs_closures: + if GCMARKP(ptr) break; + SETGCMARK(ptr); + if IMP(CDR(ptr)) { + ptr = CODE(ptr); + goto gc_mark_nimp; + } + gc_mark(CODE(ptr)); + ptr = GCCDR(ptr); + goto gc_mark_nimp; + case tc7_vector: +#ifdef CCLO + case tc7_cclo: +#endif + if GC8MARKP(ptr) break; + SETGC8MARK(ptr); + i = LENGTH(ptr); + if (i==0) break; + while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]); + ptr = VELTS(ptr)[0]; + goto gc_mark_loop; + case tc7_contin: + if GC8MARKP(ptr) break; + SETGC8MARK(ptr); + mark_locations((STACKITEM *)VELTS(ptr), + (sizet)(LENGTH(ptr) + + (sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) / + sizeof(STACKITEM))); + break; + case tc7_bvect: + case tc7_ivect: + case tc7_uvect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + case tc7_string: + case tc7_msymbol: + case tc7_ssymbol: + SETGC8MARK(ptr); + case tcs_subrs: + break; + case tc7_port: + i = PTOBNUM(ptr); + if (!(i < numptob)) goto def; + ptr = (ptobs[i].mark)(ptr); + goto gc_mark_loop; + case tc7_smob: + if GC8MARKP(ptr) break; + switch TYP16(ptr) { /* should be faster than going through smobs */ + case tc_free_cell: + /* printf("found free_cell %X ", ptr); fflush(stdout); */ + SETGC8MARK(ptr); + CDR(ptr) = EOL; + break; + case tcs_bignums: + case tc16_flo: + SETGC8MARK(ptr); + break; + default: + i = SMOBNUM(ptr); + if (!(i < numsmob)) goto def; + ptr = (smobs[i].mark)(ptr); + goto gc_mark_loop; + } + break; + default: def: wta(ptr, s_bad_type, "gc_mark"); + } +} + +void mark_locations(x, n) + STACKITEM x[]; + sizet n; +{ + register long m = n; + register int i, j; + register CELLPTR ptr; + while(0 <= --m) if CELLP(*(SCM **)&x[m]) { + ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m])); + i = 0; + j = hplim_ind; + do { + if PTR_GT(hplims[i++], ptr) break; + if PTR_LE(hplims[--j], ptr) break; + if ((i != j) + && PTR_LE(hplims[i++], ptr) + && PTR_GT(hplims[--j], ptr)) continue; + /* if NFREEP(*(SCM **)&x[m]) */ gc_mark(*(SCM *)&x[m]); + break; + } while(i<j); + } +} + +#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x)) + +static void gc_sweep() +{ + register CELLPTR ptr; +#ifdef POINTERS_MUNGED + register SCM scmptr; +#else +#define scmptr (SCM)ptr +#endif + register SCM nfreelist = EOL; + register long n = 0, m = 0; + register sizet j; + sizet i = 0; + sizet seg_size; + while (i<hplim_ind) { + ptr = CELL_UP(hplims[i++]); + seg_size = CELL_DN(hplims[i++]) - ptr; + for(j = seg_size;j--;++ptr) { +#ifdef POINTERS_MUNGED + scmptr = PTR2SCM(ptr); +#endif + switch TYP7(scmptr) { + case tcs_cons_imcar: + case tcs_cons_nimcar: + case tcs_cons_gloc: + case tcs_closures: + if GCMARKP(scmptr) goto cmrkcontinue; + break; + case tc7_vector: +#ifdef CCLO + case tc7_cclo: +#endif + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += (LENGTH(scmptr)*sizeof(SCM)); + freechars: + must_free(CHARS(scmptr)); +/* SETCHARS(scmptr, 0);*/ + break; + case tc7_bvect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT); + goto freechars; + case tc7_ivect: + case tc7_uvect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += HUGE_LENGTH(scmptr)*sizeof(long); + goto freechars; + case tc7_fvect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += HUGE_LENGTH(scmptr)*sizeof(float); + goto freechars; + case tc7_dvect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += HUGE_LENGTH(scmptr)*sizeof(double); + goto freechars; + case tc7_cvect: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += HUGE_LENGTH(scmptr)*2*sizeof(double); + goto freechars; + case tc7_string: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += HUGE_LENGTH(scmptr)+1; + goto freechars; + case tc7_msymbol: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += LENGTH(scmptr)+1; + goto freechars; + case tc7_contin: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); +/* free_continuation(CONT(scmptr)); */ + goto freechars; + case tc7_ssymbol: + if GC8MARKP(scmptr) goto c8mrkcontinue; + /* Do not free storage because tc7_ssymbol means scmptr's + storage was not created by a call to malloc(). */ + break; + case tcs_subrs: + continue; + case tc7_port: + if GC8MARKP(scmptr) goto c8mrkcontinue; + if OPENP(scmptr) { + int k = PTOBNUM(scmptr); + if (!(k < numptob)) goto sweeperr; + /* Yes, I really do mean ptobs[k].free */ + /* rather than ftobs[k].close. .close */ + /* is for explicit CLOSE-PORT by user */ + (ptobs[k].free)(STREAM(scmptr)); + gc_ports_collected++; + SETSTREAM(scmptr, 0); + CAR(scmptr) &= ~OPN; + } + break; + case tc7_smob: + switch GCTYP16(scmptr) { + case tc_free_cell: + if GC8MARKP(scmptr) goto c8mrkcontinue; + break; +#ifdef BIGDIG + case tcs_bignums: + if GC8MARKP(scmptr) goto c8mrkcontinue; + m += (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT); + goto freechars; +#endif /* def BIGDIG */ + case tc16_flo: + if GC8MARKP(scmptr) goto c8mrkcontinue; + switch ((int)(CAR(scmptr)>>16)) { + case (IMAG_PART | REAL_PART)>>16: + m += sizeof(double); + case REAL_PART>>16: + case IMAG_PART>>16: + m += sizeof(double); + goto freechars; + case 0: + break; + default: + goto sweeperr; + } + break; + default: + if GC8MARKP(scmptr) goto c8mrkcontinue; + { + int k = SMOBNUM(scmptr); + if (!(k < numsmob)) goto sweeperr; + m += (smobs[k].free)((CELLPTR)scmptr); + } + } + break; + default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep"); + } + ++n; + CAR(scmptr) = (SCM)tc_free_cell; + CDR(scmptr) = nfreelist; + nfreelist = scmptr; + continue; + c8mrkcontinue: + CLRGC8MARK(scmptr); + continue; + cmrkcontinue: + CLRGCMARK(scmptr); + } +#ifdef GC_FREE_SEGMENTS + if (n==seg_size) { + heap_size -= seg_size; + must_free((char *)hplims[i-2]); + hplims[i-2] = 0; + for(j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j]; + hplim_ind -= 2; + i -= 2; /* need to scan segment just moved. */ + nfreelist = freelist; + } + else +#endif /* ifdef GC_FREE_SEGMENTS */ + freelist = nfreelist; + gc_cells_collected += n; + n = 0; + } + lcells_allocated += (heap_size - gc_cells_collected - cells_allocated); + cells_allocated = (heap_size - gc_cells_collected); + lmallocated -= m; + mallocated -= m; + gc_malloc_collected = m; +} + +/* mark_syms marks those symbols of hash table V which have + non-UNDEFINED values. */ +static char s_gc_sym[] = "mark_syms"; +static void mark_syms(v) + SCM v; +{ + SCM x, al; + int k = LENGTH(v); + while (k--) + for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) { + /* If this bucket has already been marked, then something is wrong. */ + ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym); + x = CAR(al); + SETGCMARK(al); + ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym); + if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x))) + goto used; /* Don't mark symbol. */ + SETGC8MARK(CAR(x)); + used: + SETGCMARK(x); /* Do mark value cell. */ + } + SETGC8MARK(v); /* Mark bucket list. */ +} + +/* mark_symhash marks the values of hash table V. */ +static void mark_sym_values(v) + SCM v; +{ + SCM x, al; + int k = LENGTH(v); + SETGC8MARK(v); + while (k--) + for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) { + x = GCCDR(CAR(al)); + if IMP(x) continue; + gc_mark(x); + } +} + +/* Splice any unused valueless symbols out of the hash buckets. */ +static void sweep_symhash(v) + SCM v; +{ + SCM al, x, *lloc; + int k = LENGTH(v); + while (k--) { + lloc = &(VELTS(v)[k]); + while NIMP(al = (*lloc & ~1L)) { + x = CAR(al); + if GC8MARKP(CAR(x)) + lloc = &(CDR(al)); + else { + *lloc = CDR(al); + CLRGCMARK(al); /* bucket pair to be collected by gc_sweep */ + CLRGCMARK(x); /* value cell to be collected by gc_sweep */ + gc_syms_collected++; + } + } + VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */ + } +} @@ -0,0 +1,389 @@ +/* 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. + */ + +/* "time.c" functions dealing with time. + Author: Aubrey Jaffer */ + +#include "scm.h" + +#ifdef HAVE_CONFIG_H + +# ifndef HAVE_FTIME +# define LACK_FTIME +# endif +# ifndef HAVE_TIMES +# define LACK_TIMES +# 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 HAVE_FTIME +# ifdef unix +# ifndef GO32 +# include <sys/timeb.h> +# endif +# endif +# endif + +#else + +# ifdef STDC_HEADERS +# include <time.h> +# ifdef M_SYSV +# include <sys/types.h> +# include <sys/times.h> +# endif +# ifdef sun +# include <sys/types.h> +# include <sys/times.h> +# endif +# ifdef ultrix +# include <sys/types.h> +# include <sys/times.h> +# endif +# ifdef nosve +# include <sys/types.h> +# include <sys/times.h> +# endif +# ifdef _UNICOS +# include <sys/types.h> +# include <sys/times.h> +# endif +# ifdef __IBMC__ +# include <sys/timeb.h> +# endif +# else +# ifdef SVR2 +# include <time.h> +# else +# ifndef ARM_ULIB +# include <sys/time.h> +# else +# include <time.h> +# endif +# endif +# include <sys/types.h> + +# ifndef ARM_ULIB +# include <sys/times.h> +# else +# include <time.h> +# endif + +# endif + +/* Define this if your system lacks ftime(). */ +/* #define LACK_FTIME */ +/* Define this if your system lacks times(). */ +/* #define LACK_TIMES */ + +# ifdef __TURBOC__ +# define LACK_TIMES +# endif +# if (__TURBOC__==1) /* Needed for TURBOC V1.0 */ +# define LACK_FTIME +# undef MSDOS +# endif +# ifdef __HIGHC__ +# define LACK_TIMES +# endif +# ifdef THINK_C +# define LACK_FTIME +# define LACK_TIMES +# define CLK_TCK 60 +# endif +# ifdef SVR2 +# define LACK_FTIME +# endif +# ifdef SVR4 +# define LACK_FTIME +# endif +# ifdef __svr4__ +# define LACK_FTIME +# endif +# ifdef nosve +# define LACK_FTIME +# endif +# ifdef GO32 +# define LACK_FTIME +# define LACK_TIMES +# endif +# ifdef atarist +# define LACK_FTIME +# define LACK_TIMES +# endif +# ifdef ARM_ULIB +# define LACK_FTIME +# define LACK_TIMES +# endif +# ifdef _DCC +# define LACK_FTIME +# endif +# ifdef MSDOS +# ifndef GO32 +# include <sys/types.h> +# include <sys/timeb.h> +# endif +# endif +# ifdef _UNICOS +# define LACK_FTIME +# endif + +# ifndef LACK_FTIME +# ifdef unix +# ifndef GO32 +# include <sys/timeb.h> +# endif +# endif +# endif + +# ifdef __EMX__ +# define LACK_TIMES +# include <sys/types.h> +# include <sys/timeb.h> +# endif + +# ifdef MWC +# include <time.h> +# include <sys/timeb.h> +# endif + +# ifdef ARM_ULIB +# include <sys/types.h> +# include <time.h> +# endif + +#endif /* HAVE_CONFIG_H */ + +#ifdef vms +# define LACK_TIMES +# define LACK_FTIME +#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 +# ifdef AMIGA +# include <stddef.h> +# define LACK_TIMES +# define LACK_FTIME +# define CLKTCK 1000 +# else +# define CLKTCK 60 +# endif +# endif +#endif + +#ifdef __STDC__ +# define timet time_t +#else +# define timet long +#endif + +#ifdef LACK_TIMES +# ifdef LACK_CLOCK +# ifdef AMIGA +/* From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> */ +# ifdef AZTEC_C /* AZTEC_C */ +# include <devices/timer.h> +static long mytime() +{ + long sec, mic, mili = 0; + struct timerequest *timermsg; + struct MsgPort *timerport; + if(!(timerport = (struct MsgPort *)CreatePort(0, 0))){ + lputs("No mem for port.\n", cur_errp); + return mili; + } + if(!(timermsg = (struct timerequest *) + CreateExtIO(timerport, sizeof(struct timerequest)))){ + lputs("No mem for timerequest.\n", cur_errp); + DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort); + return mili; + } + if(!(OpenDevice(TIMERNAME, UNIT_MICROHZ, timermsg, 0))){ + timermsg->tr_node.io_Command = TR_GETSYSTIME; + timermsg->tr_node.io_Flags = 0; + DoIO(timermsg); + sec = timermsg->tr_time.tv_secs; + mic = timermsg->tr_time.tv_micro; + mili = sec*1000+mic/1000; + CloseDevice(timermsg); + } + else lputs("No Timer available.\n", cur_errp); + DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort); + DeleteExtIO(timermsg); + return mili ; +} +# else /* this is for SAS/C */ +static long mytime() +{ + unsigned int cl[2]; + timer(cl); + return(cl[0]*1000+cl[1]/1000); +} +# endif /* AZTEC_C */ +# else /* AMIGA */ +# define mytime() ((time((timet*)0) - your_base) * CLKTCK) +# endif /* AMIGA */ +# else /* LACK_CLOCK */ +# define mytime clock +# endif /* LACK_CLOCK */ +#else /* LACK_TIMES */ +static long mytime() +{ + struct tms time_buffer; + times(&time_buffer); + return time_buffer.tms_utime + time_buffer.tms_stime; +} +#endif /* LACK_TIMES */ + +#ifdef LACK_FTIME +# ifdef AMIGA +SCM your_time() +{ + return MAKINUM(mytime()); +} +# else +timet your_base = 0; +SCM your_time() +{ + return MAKINUM((time((timet*)0) - your_base) * (int)CLKTCK); +} +# endif /* AMIGA */ +#else /* LACK_FTIME */ +struct timeb your_base = {0}; +SCM your_time() +{ + struct timeb time_buffer; + long tmp; + ftime(&time_buffer); + time_buffer.time -= your_base.time; + tmp = time_buffer.millitm - your_base.millitm; + tmp = time_buffer.time*1000L + tmp; + tmp *= CLKTCK; + tmp /= 1000; + return MAKINUM(tmp); +} +#endif /* LACK_FTIME */ + +long my_base = 0; +SCM my_time() +{ + return MAKINUM(mytime()-my_base); +} + +SCM curtime() +{ + timet timv = time((timet*)0); + SCM ans; +#ifndef _DCC +# ifdef STDC_HEADERS +# if (__TURBOC__ > 0x201) + timv = mktime(gmtime(&timv)); +# endif +# endif +#endif + ans = ulong2num(timv); + return BOOL_F==ans ? MAKINUM(timv) : ans; +} + +long 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); +} + +static iproc subr0s[] = { + {"get-internal-run-time", my_time}, + {"get-internal-real-time", your_time}, + {"current-time", curtime}, + {0, 0}}; + +void init_time() +{ + sysintern("internal-time-units-per-second", + MAKINUM((long)CLKTCK)); +#ifdef LACK_FTIME +# ifndef AMIGA + if (!your_base) time(&your_base); +# endif +#else + if (!your_base.time) ftime(&your_base); +#endif + if (!my_base) my_base = mytime(); + init_iprocs(subr0s, tc7_subr_0); +} diff --git a/unexec.c b/unexec.c new file mode 100644 index 0000000..f7ff9ca --- /dev/null +++ b/unexec.c @@ -0,0 +1,1238 @@ +/* Copyright (C) 1985,86,87,88,92,93,94 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. */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Modified to support SysVr3 shared libraries by James Van Artsdalen + * of Dell Computer Corporation. james@bigtex.cactus.org. + */ + +/* There are several compilation parameters affecting unexec: + +* COFF + +Define this if your system uses COFF for executables. + +* COFF_ENCAPSULATE + +Define this if you are using the GNU coff encapsulated a.out format. +This is closer to a.out than COFF. You should *not* define COFF if +you define COFF_ENCAPSULATE + +Otherwise we assume you use Berkeley format. + +* NO_REMAP + +Define this if you do not want to try to save Emacs's pure data areas +as part of the text segment. + +Saving them as text is good because it allows users to share more. + +However, on machines that locate the text area far from the data area, +the boundary cannot feasibly be moved. Such machines require +NO_REMAP. + +Also, remapping can cause trouble with the built-in startup routine +/lib/crt0.o, which defines `environ' as an initialized variable. +Dumping `environ' as pure does not work! So, to use remapping, +you must write a startup routine for your machine in Emacs's crt0.c. +If NO_REMAP is defined, Emacs uses the system's crt0.o. + +* SECTION_ALIGNMENT + +Some machines that use COFF executables require that each section +start on a certain boundary *in the COFF file*. Such machines should +define SECTION_ALIGNMENT to a mask of the low-order bits that must be +zero on such a boundary. This mask is used to control padding between +segments in the COFF file. + +If SECTION_ALIGNMENT is not defined, the segments are written +consecutively with no attempt at alignment. This is right for +unmodified system V. + +* SEGMENT_MASK + +Some machines require that the beginnings and ends of segments +*in core* be on certain boundaries. For most machines, a page +boundary is sufficient. That is the default. When a larger +boundary is needed, define SEGMENT_MASK to a mask of +the bits that must be zero on such a boundary. + +* A_TEXT_OFFSET(HDR) + +Some machines count the a.out header as part of the size of the text +segment (a_text); they may actually load the header into core as the +first data in the text segment. Some have additional padding between +the header and the real text of the program that is counted in a_text. + +For these machines, define A_TEXT_OFFSET(HDR) to examine the header +structure HDR and return the number of bytes to add to `a_text' +before writing it (above and beyond the number of bytes of actual +program text). HDR's standard fields are already correct, except that +this adjustment to the `a_text' field has not yet been made; +thus, the amount of offset can depend on the data in the file. + +* A_TEXT_SEEK(HDR) + +If defined, this macro specifies the number of bytes to seek into the +a.out file before starting to write the text segment. + +* EXEC_MAGIC + +For machines using COFF, this macro, if defined, is a value stored +into the magic number field of the output file. + +* ADJUST_EXEC_HEADER + +This macro can be used to generate statements to adjust or +initialize nonstandard fields in the file header + +* ADDR_CORRECT(ADDR) + +Macro to correct an int which is the bit pattern of a pointer to a byte +into an int which is the number of a byte. + +This macro has a default definition which is usually right. +This default definition is a no-op on most machines (where a +pointer looks like an int) but not on all machines. + +*/ + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#define IN_UNEXEC +#include <config.h> +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef COFF_ENCAPSULATE +int need_coff_header = 1; +#include <coff-encap/a.out.encap.h> /* The location might be a poor assumption */ +#else +#ifdef MSDOS +#if __DJGPP__ > 1 +#include <fcntl.h> /* for O_RDONLY, O_RDWR */ +#include <crt0.h> /* for _crt0_startup_flags and its bits */ +static int save_djgpp_startup_flags; +#endif +#include <coff.h> +#define filehdr external_filehdr +#define scnhdr external_scnhdr +#define syment external_syment +#define auxent external_auxent +#define n_numaux e_numaux +#define n_type e_type +struct aouthdr +{ + unsigned short magic; /* type of file */ + unsigned short vstamp; /* version stamp */ + unsigned long tsize; /* text size in bytes, padded to FW bdry*/ + unsigned long dsize; /* initialized data " " */ + unsigned long bsize; /* uninitialized data " " */ + unsigned long entry; /* entry pt. */ + unsigned long text_start;/* base of text used for this file */ + unsigned long data_start;/* base of data used for this file */ +}; + + +#else /* not MSDOS */ +#include <a.out.h> +#endif /* not MSDOS */ +#endif + +/* Define getpagesize if the system does not. + Note that this may depend on symbols defined in a.out.h. */ +#include "getpagesize.h" + +#ifndef makedev /* Try to detect types.h already loaded */ +#include <sys/types.h> +#endif /* makedev */ +#include <stdio.h> +#include <sys/stat.h> +#include <errno.h> + +#include <sys/file.h> /* Must be after sys/types.h for USG and BSD4_1*/ + +#ifdef USG5 +#include <fcntl.h> +#endif + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif + + +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ + +#ifdef COFF +static long block_copy_start; /* Old executable start point */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ +#define SYMS_START block_copy_start + +static long text_scnptr; +static long data_scnptr; + +#else /* not COFF */ + +#ifdef HPUX +extern void *sbrk (); +#else +#if 0 +/* Some systems with __STDC__ compilers still declare this `char *' in some + header file, and our declaration conflicts. The return value is always + cast, so it should be harmless to leave it undefined. Hopefully + machines with different size pointers and ints declare sbrk in a header + file. */ +#ifdef __STDC__ +extern void *sbrk (); +#else +extern char *sbrk (); +#endif /* __STDC__ */ +#endif +#endif /* HPUX */ + +#define SYMS_START ((long) N_SYMOFF (ohdr)) + +/* Some machines override the structure name for an a.out header. */ +#ifndef EXEC_HDR_TYPE +#define EXEC_HDR_TYPE struct exec +#endif + +#ifdef HPUX +#ifdef HP9000S200_ID +#define MY_ID HP9000S200_ID +#else +#include <model.h> +#define MY_ID MYSYS +#endif /* no HP9000S200_ID */ +static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; +static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; +#define N_TXTOFF(x) TEXT_OFFSET(x) +#define N_SYMOFF(x) LESYM_OFFSET(x) +static EXEC_HDR_TYPE hdr, ohdr; + +#else /* not HPUX */ + +#if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX) +static struct bhdr hdr, ohdr; +#define a_magic fmagic +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#define a_entry entry +#define N_BADMAG(x) \ + (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ + ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) +#define NEWMAGIC FMAGIC +#else /* IRIS or IBMAIX or not USG */ +static EXEC_HDR_TYPE hdr, ohdr; +#define NEWMAGIC ZMAGIC +#endif /* IRIS or IBMAIX not USG */ +#endif /* not HPUX */ + +static int unexec_text_start; +static int unexec_data_start; + +#ifdef COFF_ENCAPSULATE +/* coffheader is defined in the GNU a.out.encap.h file. */ +struct coffheader coffheader; +#endif + +#endif /* not COFF */ + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) +#endif + +#ifdef emacs + +#include "lisp.h" + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (fd, msg, a1, a2) + int fd; + char *msg; + int a1, a2; +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +static int make_hdr (); +static int copy_text_and_data (); +static int copy_sym (); +static void mark_x (); + +/* **************************************************************** + * unexec + * + * driving logic. + */ +unexec (new_name, a_name, data_start, bss_start, entry_address) + char *new_name, *a_name; + unsigned data_start, bss_start, entry_address; +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + + if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 + || copy_text_and_data (new, a_out) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + || adjust_lnnoptrs (new, a_out, new_name) < 0 +#endif +#endif + ) + { + close (new); + /* unlink (new_name); /* Failed, unlink new a.out */ + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + mark_x (new_name); + return 0; +} + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) + int new, a_out; + unsigned data_start, bss_start, entry_address; + char *a_name; + char *new_name; +{ + int tem; +#ifdef COFF + auto struct scnhdr f_thdr; /* Text section header */ + auto struct scnhdr f_dhdr; /* Data section header */ + auto struct scnhdr f_bhdr; /* Bss section header */ + auto struct scnhdr scntemp; /* Temporary section header */ + register int scns; +#endif /* COFF */ +#ifdef USG_SHARED_LIBRARIES + extern unsigned int bss_end; +#else + unsigned int bss_end; +#endif + + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ +#ifdef NO_REMAP + data_start = (int) start_of_data (); +#else /* not NO_REMAP */ + if (!data_start) + data_start = (int) start_of_data (); +#endif /* not NO_REMAP */ + data_start = ADDR_CORRECT (data_start); + +#ifdef SEGMENT_MASK + data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ +#else + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ +#endif + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + +#ifdef COFF + /* Salvage as much info from the existing file as possible */ + if (a_out >= 0) + { + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_hdr); + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_ohdr); + } + /* Loop through section headers, copying them in */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + for (scns = f_hdr.f_nscns; scns > 0; scns--) { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + { + PERROR (a_name); + } + if (scntemp.s_scnptr > 0L) + { + if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) + block_copy_start = scntemp.s_scnptr + scntemp.s_size; + } + if (strcmp (scntemp.s_name, ".text") == 0) + { + f_thdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".data") == 0) + { + f_dhdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".bss") == 0) + { + f_bhdr = scntemp; + } + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + +#ifdef USG_SHARED_LIBRARIES + + /* The amount of data we're adding to the file is distance from the + * end of the original .data space to the current end of the .data + * space. + */ + + bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size); + +#endif + + f_hdr.f_flags |= (F_RELFLG | F_EXEC); +#ifdef TPIX + f_hdr.f_nscns = 3; +#endif +#ifdef EXEC_MAGIC + f_ohdr.magic = EXEC_MAGIC; +#endif +#ifndef NO_REMAP + f_ohdr.text_start = (long) start_of_text (); + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.data_start = data_start; +#endif /* NO_REMAP */ + f_ohdr.dsize = bss_start - f_ohdr.data_start; + f_ohdr.bsize = bss_end - bss_start; +#ifndef KEEP_OLD_TEXT_SCNPTR + /* On some machines, the old values are right. + ??? Maybe on all machines with NO_REMAP. */ + f_thdr.s_size = f_ohdr.tsize; + f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); + f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif /* KEEP_OLD_TEXT_SCNPTR */ +#ifdef ADJUST_TEXT_SCNHDR_SIZE + /* On some machines, `text size' includes all headers. */ + f_thdr.s_size -= f_thdr.s_scnptr; +#endif /* ADJUST_TEST_SCNHDR_SIZE */ + lnnoptr = f_thdr.s_lnnoptr; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_thdr.s_scnptr + = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef TPIX + f_thdr.s_scnptr = 0xd0; +#endif + text_scnptr = f_thdr.s_scnptr; +#ifdef ADJUST_TEXTBASE + text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif +#ifndef KEEP_OLD_PADDR + f_dhdr.s_paddr = f_ohdr.data_start; +#endif /* KEEP_OLD_PADDR */ + f_dhdr.s_vaddr = f_ohdr.data_start; + f_dhdr.s_size = f_ohdr.dsize; + f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef DATA_SECTION_ALIGNMENT + /* Some systems require special alignment + of the data section only. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; +#endif /* DATA_SECTION_ALIGNMENT */ + data_scnptr = f_dhdr.s_scnptr; +#ifndef KEEP_OLD_PADDR + f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; +#endif /* KEEP_OLD_PADDR */ + f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_size = f_ohdr.bsize; + f_bhdr.s_scnptr = 0L; +#ifndef USG_SHARED_LIBRARIES + bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; +#endif + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + if (f_thdr.s_lnnoptr > 0L) + { + f_thdr.s_lnnoptr += bias; + } + +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + +#ifndef USG_SHARED_LIBRARIES + + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + { + PERROR (new_name); + } + + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + { + PERROR (new_name); + } + + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + { + PERROR (new_name); + } + +#else /* USG_SHARED_LIBRARIES */ + + /* The purpose of this code is to write out the new file's section + * header table. + * + * Scan through the original file's sections. If the encountered + * section is one we know (.text, .data or .bss), write out the + * correct header. If it is a section we do not know (such as + * .lib), adjust the address of where the section data is in the + * file, and write out the header. + * + * If any section precedes .text or .data in the file, this code + * will not adjust the file pointer for that section correctly. + */ + + /* This used to use sizeof (f_ohdr) instead of .f_opthdr. + .f_opthdr is said to be right when there is no optional header. */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (a_name); + + if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ + { + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ + { + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ + { + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + PERROR (new_name); + } + else + { + if (scntemp.s_scnptr) + scntemp.s_scnptr += bias; + if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (new_name); + } + } +#endif /* USG_SHARED_LIBRARIES */ + + return (0); + +#else /* if not COFF */ + + /* Get symbol table info from header of a.out file if given one. */ + if (a_out >= 0) + { +#ifdef COFF_ENCAPSULATE + if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(a_name); + } + if (coffheader.f_magic != COFF_MAGIC) + { + ERROR1("%s doesn't have legal coff magic number\n", a_name); + } +#endif + if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) + { + PERROR (a_name); + } + + if (N_BADMAG (ohdr)) + { + ERROR1 ("invalid magic number in %s", a_name); + } + hdr = ohdr; + } + else + { +#ifdef COFF_ENCAPSULATE + /* We probably could without too much trouble. The code is in gld + * but I don't have that much time or incentive. + */ + ERROR0 ("can't build a COFF file from scratch yet"); +#else +#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ + bzero ((void *)&hdr, sizeof hdr); +#else + bzero (&hdr, sizeof hdr); +#endif +#endif + } + + unexec_text_start = (long) start_of_text (); + unexec_data_start = data_start; + + /* Machine-dependent fixup for header, or maybe for unexec_text_start */ +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + hdr.a_trsize = 0; + hdr.a_drsize = 0; + if (entry_address != 0) + hdr.a_entry = entry_address; + + hdr.a_bss = bss_end - bss_start; + hdr.a_data = bss_start - data_start; +#ifdef NO_REMAP + hdr.a_text = ohdr.a_text; +#else /* not NO_REMAP */ + hdr.a_text = data_start - unexec_text_start; + +#ifdef A_TEXT_OFFSET + hdr.a_text += A_TEXT_OFFSET (ohdr); +#endif + +#endif /* not NO_REMAP */ + +#ifdef COFF_ENCAPSULATE + /* We are encapsulating BSD format within COFF format. */ + { + struct coffscn *tp, *dp, *bp; + tp = &coffheader.scns[0]; + dp = &coffheader.scns[1]; + bp = &coffheader.scns[2]; + tp->s_size = hdr.a_text + sizeof(struct exec); + dp->s_paddr = data_start; + dp->s_vaddr = data_start; + dp->s_size = hdr.a_data; + bp->s_paddr = dp->s_vaddr + dp->s_size; + bp->s_vaddr = bp->s_paddr; + bp->s_size = hdr.a_bss; + coffheader.tsize = tp->s_size; + coffheader.dsize = dp->s_size; + coffheader.bsize = bp->s_size; + coffheader.text_start = tp->s_vaddr; + coffheader.data_start = dp->s_vaddr; + } + if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(new_name); + } +#endif /* COFF_ENCAPSULATE */ + + if (write (new, &hdr, sizeof hdr) != sizeof hdr) + { + PERROR (new_name); + } + +#if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */ + /* This adjustment was done above only #ifndef NO_REMAP, + so only undo it now #ifndef NO_REMAP. */ + /* #ifndef NO_REMAP */ +#endif +#ifdef A_TEXT_OFFSET + hdr.a_text -= A_TEXT_OFFSET (ohdr); +#endif + + return 0; + +#endif /* not COFF */ +} + +/* **************************************************************** + * copy_text_and_data + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (new, a_out) + int new, a_out; +{ + register char *end; + register char *ptr; + +#ifdef COFF + +#ifdef USG_SHARED_LIBRARIES + + int scns; + struct scnhdr scntemp; /* Temporary section header */ + + /* The purpose of this code is to write out the new file's section + * contents. + * + * Step through the section table. If we know the section (.text, + * .data) do the appropriate thing. Otherwise, if the section has + * no allocated space in the file (.bss), do nothing. Otherwise, + * the section has space allocated in the file, and is not a section + * we know. So just copy it. + */ + + lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR ("temacs"); + + if (!strcmp (scntemp.s_name, ".text")) + { + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + } + else if (!strcmp (scntemp.s_name, ".data")) + { + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + } + else if (!scntemp.s_scnptr) + ; /* do nothing - no data for this section */ + else + { + char page[BUFSIZ]; + int size, n; + long old_a_out_ptr = lseek (a_out, 0, 1); + + lseek (a_out, scntemp.s_scnptr, 0); + for (size = scntemp.s_size; size > 0; size -= sizeof (page)) + { + n = size > sizeof (page) ? sizeof (page) : size; + if (read (a_out, page, n) != n || write (new, page, n) != n) + PERROR ("emacs"); + } + lseek (a_out, old_a_out_ptr, 0); + } + } + +#else /* COFF, but not USG_SHARED_LIBRARIES */ + +#ifdef MSDOS +#if __DJGPP__ >= 2 + /* Dump the original table of exception handlers, not the one + where our exception hooks are registered. */ + __djgpp_exception_toggle (); + + /* Switch off startup flags that might have been set at runtime + and which might change the way that dumped Emacs works. */ + save_djgpp_startup_flags = _crt0_startup_flags; + _crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR); +#endif +#endif + + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; +#ifdef HEADER_INCL_IN_TEXT + /* For Gould UTX/32, text starts after headers */ + ptr = (char *) (ptr + text_scnptr); +#endif /* HEADER_INCL_IN_TEXT */ + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + +#ifdef MSDOS +#if __DJGPP__ >= 2 + /* Restore our exception hooks. */ + __djgpp_exception_toggle (); + + /* Restore the startup flags. */ + _crt0_startup_flags = save_djgpp_startup_flags; +#endif +#endif + +#endif /* USG_SHARED_LIBRARIES */ + +#else /* if not COFF */ + +/* Some machines count the header as part of the text segment. + That is to say, the header appears in core + just before the address that start_of_text returns. + For them, N_TXTOFF is the place where the header goes. + We must adjust the seek to the place after the header. + Note that at this point hdr.a_text does *not* count + the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ + +#ifdef A_TEXT_SEEK + lseek (new, (long) A_TEXT_SEEK (hdr), 0); +#else + lseek (new, (long) N_TXTOFF (hdr), 0); +#endif /* no A_TEXT_SEEK */ + +#ifdef RISCiX + + /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. + * There is a little table in crt0.o that is filled at link time with + * the min and current brk positions, among other things. When start + * runs, it copies the table to where these parameters live during + * execution. This data is in text space, so it cannot be modified here + * before saving the executable, so the data is written manually. In + * addition, the table does not have a label, and the nearest accessible + * label (mcount) is not prefixed with a '_', thus making it inaccessible + * from within C programs. To overcome this, emacs's executable is passed + * through the command 'nm %s | fgrep mcount' into a pipe, and the + * resultant output is then used to find the address of 'mcount'. As far as + * is possible to determine, in RISC-iX releases prior to 1.2, the negative + * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is + * 0x30. bss_end has been rounded up to page boundary. This solution is + * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and + * avoids the need for a custom version of crt0.o for emacs which has its + * table in data space. + */ + + { + char command[1024]; + char errbuf[1024]; + char address_text[32]; + int proforma[4]; + FILE *pfile; + char *temp_ptr; + char c; + int mcount_address, mcount_offset, count; + extern char *_execname; + + + /* The use of _execname is incompatible with RISCiX 1.1 */ + sprintf (command, "nm %s | fgrep mcount", _execname); + + if ( (pfile = popen(command, "r")) == NULL) + { + sprintf (errbuf, "Could not open pipe"); + PERROR (errbuf); + } + + count=0; + while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31)) + address_text[count++]=c; + address_text[count]=0; + + if ((count == 0) || pclose(pfile) != NULL) + { + sprintf (errbuf, "Failed to execute the command '%s'\n", command); + PERROR (errbuf); + } + + sscanf(address_text, "%x", &mcount_address); + ptr = (char *) unexec_text_start; + mcount_offset = (char *)mcount_address - ptr; + +#ifdef RISCiX_1_1 +#define EDATA_OFFSET 0x2c +#else +#define EDATA_OFFSET 0x30 +#endif + + end = ptr + mcount_offset - EDATA_OFFSET; + + write_segment (new, ptr, end); + + proforma[0] = bss_end; /* becomes _edata */ + proforma[1] = bss_end; /* becomes _end */ + proforma[2] = bss_end; /* becomes _minbrk */ + proforma[3] = bss_end; /* becomes _curbrk */ + + write (new, proforma, 16); + + temp_ptr = ptr; + ptr = end + 16; + end = temp_ptr + hdr.a_text; + + write_segment (new, ptr, end); + } + +#else /* !RISCiX */ + ptr = (char *) unexec_text_start; + end = ptr + hdr.a_text; + write_segment (new, ptr, end); +#endif /* RISCiX */ + + ptr = (char *) unexec_data_start; + end = ptr + hdr.a_data; +/* This lseek is certainly incorrect when A_TEXT_OFFSET + and I believe it is a no-op otherwise. + Let's see if its absence ever fails. */ +/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ + write_segment (new, ptr, end); + +#endif /* not COFF */ + + return 0; +} + +write_segment (new, ptr, end) + int new; + register char *ptr, *end; +{ + register int i, nwrite, ret; + char buf[80]; + extern int errno; + /* This is the normal amount to write at once. + It is the size of block that NFS uses. */ + int writesize = 1 << 13; + int pagesize = getpagesize (); + char zeros[1 << 13]; + + bzero (zeros, sizeof (zeros)); + + for (i = 0; ptr < end;) + { + /* Distance to next multiple of writesize. */ + nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 +#ifdef EFAULT + && errno == EFAULT +#endif + ) + { + /* Write only a page of zeros at once, + so that we we don't overshoot the start + of the valid memory in the old data segment. */ + if (nwrite > pagesize) + nwrite = pagesize; + write (new, zeros, nwrite); + } +#if 0 /* Now that we have can ask `write' to write more than a page, + it is legit for write do less than the whole amount specified. */ + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", + ptr, new, nwrite, ret, errno); + PERROR (buf); + } +#endif + i += nwrite; + ptr += nwrite; + } +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (new, a_out, a_name, new_name) + int new, a_out; + char *a_name, *new_name; +{ + char page[1024]; + int n; + + if (a_out < 0) + return 0; + +#ifdef COFF + if (SYMS_START == 0L) + return 0; +#endif /* COFF */ + +#ifdef COFF + if (lnnoptr) /* if there is line number info */ + lseek (a_out, lnnoptr, 0); /* start copying from there */ + else +#endif /* COFF */ + lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After successfully building the new a.out, mark it executable + */ +static void +mark_x (name) + char *name; +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); +} + +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + */ + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int new; +#if defined (amdahl_uts) || defined (pfa) + SYMENT symentry; + AUXENT auxentry; +#else + struct syment symentry; + union auxent auxentry; +#endif + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + +#ifdef MSDOS + if ((new = writedesc) < 0) +#else + if ((new = open (new_name, O_RDWR)) < 0) +#endif + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_numaux) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) + { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } +#ifndef MSDOS + close (new); +#endif + return 0; +} + +#endif /* COFF_BSD_SYMBOLS */ + +#endif /* COFF */ + +#endif /* not CANNOT_DUMP */ diff --git a/unexelf.c b/unexelf.c new file mode 100644 index 0000000..60e82cc --- /dev/null +++ b/unexelf.c @@ -0,0 +1,908 @@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 + 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. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. + * ELF support added. + * + * Basic theory: the data space of the running process needs to be + * dumped to the output file. Normally we would just enlarge the size + * of .data, scooting everything down. But we can't do that in ELF, + * because there is often something between the .data space and the + * .bss space. + * + * In the temacs dump below, notice that the Global Offset Table + * (.got) and the Dynamic link data (.dynamic) come between .data1 and + * .bss. It does not work to overlap .data with these fields. + * + * The solution is to create a new .data segment. This segment is + * filled with data from the current process. Since the contents of + * various sections refer to sections by index, the new .data segment + * is made the last in the table to avoid changing any existing index. + + * This is an example of how the section headers are changed. "Addr" + * is a process virtual address. "Offset" is a file offset. + +raid:/nfs/raid/src/dist-18.56/src> dump -h temacs + +temacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80a98f4 0x608f4 0x449c .bss + 0 0 0x4 0 + +[17] 2 0 0 0x608f4 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x6a484 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x729aa 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x72a3d 0x68b7 .comment + 0 0 0x1 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs + +xemacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[17] 2 0 0 0x7d800 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + +[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + + * This is an example of how the file header is changed. "Shoff" is + * the section header offset within the file. Since that table is + * after the new .data section, it is moved. "Shnum" is the number of + * sections, which we increment. + * + * "Phoff" is the file offset to the program header. "Phentsize" and + * "Shentsz" are the program and section header entries sizes respectively. + * These can be larger than the apparent struct sizes. + +raid:/nfs/raid/src/dist-18.56/src> dump -f temacs + +temacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x792f4 0 0x34 +0x20 5 0x28 21 19 + +raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs + +xemacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x96200 0 0x34 +0x20 5 0x28 22 19 + + * These are the program headers. "Offset" is the file offset to the + * segment. "Vaddr" is the memory load address. "Filesz" is the + * segment size as it appears in the file, and "Memsz" is the size in + * memory. Below, the third segment is the code and the fourth is the + * data: the difference between Filesz and Memsz is .bss + +raid:/nfs/raid/src/dist-18.56/src> dump -o temacs + +temacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x215c4 0x25a60 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs + +xemacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x3e4d0 0x3e4d0 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + + + */ + +/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. + * + * The above mechanism does not work if the unexeced ELF file is being + * re-layout by other applications (such as `strip'). All the applications + * that re-layout the internal of ELF will layout all sections in ascending + * order of their file offsets. After the re-layout, the data2 section will + * still be the LAST section in the section header vector, but its file offset + * is now being pushed far away down, and causes part of it not to be mapped + * in (ie. not covered by the load segment entry in PHDR vector), therefore + * causes the new binary to fail. + * + * The solution is to modify the unexec algorithm to insert the new data2 + * section header right before the new bss section header, so their file + * offsets will be in the ascending order. Since some of the section's (all + * sections AFTER the bss section) indexes are now changed, we also need to + * modify some fields to make them point to the right sections. This is done + * by macro PATCH_INDEX. All the fields that need to be patched are: + * + * 1. ELF header e_shstrndx field. + * 2. section header sh_link and sh_info field. + * 3. symbol table entry st_shndx field. + * + * The above example now should look like: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + +[17] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[18] 2 0 0 0x7d800 0x9b90 .symtab + 19 371 0x4 0x10 + +[19] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[20] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[21] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + + */ + +#include <sys/types.h> +#include <stdio.h> +#include <sys/stat.h> +#include <memory.h> +#include <string.h> +#include <errno.h> +#include <unistd.h> +#include <fcntl.h> +#include <elf.h> +#include <sys/mman.h> + +#ifndef emacs +#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1) +#else +#include <config.h> +extern void fatal (char *, ...); +#endif + +#ifndef ELF_BSS_SECTION_NAME +#define ELF_BSS_SECTION_NAME ".bss" +#endif + +/* Get the address of a particular section or program header entry, + * accounting for the size of the entries. + */ +/* + On PPC Reference Platform running Solaris 2.5.1 + the plt section is also of type NOBI like the bss section. + (not really stored) and therefore sections after the bss + section start at the plt offset. The plt section is always + the one just before the bss section. + Thus, we modify the test from + if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) + to + if (NEW_SECTION_H (nn).sh_offset >= + OLD_SECTION_H (old_bss_index-1).sh_offset) + This is just a hack. We should put the new data section + before the .plt section. + And we should not have this routine at all but use + the libelf library to read the old file and create the new + file. + The changed code is minimal and depends on prep set in m/prep.h + Erik Deumens + Quantum Theory Project + University of Florida + deumens@qtp.ufl.edu + Apr 23, 1996 + */ + +#define OLD_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) +#define NEW_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) +#define OLD_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) +#define NEW_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) + +#define PATCH_INDEX(n) \ + do { \ + if ((int) (n) >= old_bss_index) \ + (n)++; } while (0) +typedef unsigned char byte; + +/* Round X up to a multiple of Y. */ + +int +round_up (x, y) + int x, y; +{ + int rem = x % y; + if (rem == 0) + return x; + return x - rem + y; +} + +/* **************************************************************** + * unexec + * + * driving logic. + * + * In ELF, this works by replacing the old .bss section with a new + * .data section, and inserting an empty .bss immediately afterwards. + * + */ +void +unexec (new_name, old_name, data_start, bss_start, entry_address) + char *new_name, *old_name; + unsigned data_start, bss_start, entry_address; +{ + int new_file, old_file, new_file_size; + + /* Pointers to the base of the image of the two files. */ + caddr_t old_base, new_base; + + /* Pointers to the file, program and section headers for the old and new + * files. + */ + Elf32_Ehdr *old_file_h, *new_file_h; + Elf32_Phdr *old_program_h, *new_program_h; + Elf32_Shdr *old_section_h, *new_section_h; + + /* Point to the section name table in the old file */ + char *old_section_names; + + Elf32_Addr old_bss_addr, new_bss_addr; + Elf32_Word old_bss_size, new_data2_size; + Elf32_Off new_data2_offset; + Elf32_Addr new_data2_addr; + + int n, nn, old_bss_index, old_data_index, new_data2_index; + struct stat stat_buf; + + /* Open the old file & map it into the address space. */ + + old_file = open (old_name, O_RDONLY); + + if (old_file < 0) + fatal ("Can't open %s for reading: errno %d\n", old_name, errno); + + if (fstat (old_file, &stat_buf) == -1) + fatal ("Can't fstat (%s): errno %d\n", old_name, errno); + + old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); + + if (old_base == (caddr_t) -1) + fatal ("Can't mmap (%s): errno %d\n", old_name, errno); + +#ifdef DEBUG + fprintf (stderr, "mmap (%s, %x) -> %x\n", old_name, stat_buf.st_size, + old_base); +#endif + + /* Get pointers to headers & section names */ + + old_file_h = (Elf32_Ehdr *) old_base; + old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); + old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); + old_section_names = (char *) old_base + + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; + + /* Find the old .bss section. Figure out parameters of the new + * data2 and bss sections. + */ + + for (old_bss_index = 1; old_bss_index < (int) old_file_h->e_shnum; + old_bss_index++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for .bss - found %s\n", + old_section_names + OLD_SECTION_H (old_bss_index).sh_name); +#endif + if (!strcmp (old_section_names + OLD_SECTION_H (old_bss_index).sh_name, + ELF_BSS_SECTION_NAME)) + break; + } + if (old_bss_index == old_file_h->e_shnum) + fatal ("Can't find .bss in %s.\n", old_name, 0); + + old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; +#if defined(emacs) || !defined(DEBUG) + new_bss_addr = (Elf32_Addr) sbrk (0); +#else + new_bss_addr = old_bss_addr + old_bss_size + 0x1234; +#endif + new_data2_addr = old_bss_addr; + new_data2_size = new_bss_addr - old_bss_addr; + new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset; + +#ifdef DEBUG + fprintf (stderr, "old_bss_index %d\n", old_bss_index); + fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); + fprintf (stderr, "old_bss_size %x\n", old_bss_size); + fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); + fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); + fprintf (stderr, "new_data2_size %x\n", new_data2_size); + fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); +#endif + + if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) + fatal (".bss shrank when undumping???\n", 0, 0); + + /* Set the output file to the right size and mmap it. Set + * pointers to various interesting objects. stat_buf still has + * old_file data. + */ + + new_file = open (new_name, O_RDWR | O_CREAT, 0666); + if (new_file < 0) + fatal ("Can't creat (%s): errno %d\n", new_name, errno); + + new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size; + + if (ftruncate (new_file, new_file_size)) + fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); + +#ifdef UNEXEC_USE_MAP_PRIVATE + new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_PRIVATE, + new_file, 0); +#else + new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, + new_file, 0); +#endif + + if (new_base == (caddr_t) -1) + fatal ("Can't mmap (%s): errno %d\n", new_name, errno); + + new_file_h = (Elf32_Ehdr *) new_base; + new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); + new_section_h = (Elf32_Shdr *) + ((byte *) new_base + old_file_h->e_shoff + new_data2_size); + + /* Make our new file, program and section headers as copies of the + * originals. + */ + + memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); + memcpy (new_program_h, old_program_h, + old_file_h->e_phnum * old_file_h->e_phentsize); + + /* Modify the e_shstrndx if necessary. */ + PATCH_INDEX (new_file_h->e_shstrndx); + + /* Fix up file header. We'll add one section. Section header is + * further away now. + */ + + new_file_h->e_shoff += new_data2_size; + new_file_h->e_shnum += 1; + +#ifdef DEBUG + fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); + fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); + fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); + fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); +#endif + + /* Fix up a new program header. Extend the writable data segment so + * that the bss area is covered too. Find that segment by looking + * for a segment that ends just before the .bss area. Make sure + * that no segments are above the new .data2. Put a loop at the end + * to adjust the offset and address of any segment that is above + * data2, just in case we decide to allow this later. + */ + + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + /* Compute maximum of all requirements for alignment of section. */ + int alignment = (NEW_PROGRAM_H (n)).p_align; + if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) + alignment = OLD_SECTION_H (old_bss_index).sh_addralign; + + if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) + fatal ("Program segment above .bss in %s\n", old_name, 0); + + if (NEW_PROGRAM_H (n).p_type == PT_LOAD + && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + + (NEW_PROGRAM_H (n)).p_filesz, + alignment) + == round_up (old_bss_addr, alignment))) + break; + } + if (n < 0) + fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); + + NEW_PROGRAM_H (n).p_filesz += new_data2_size; + NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; + +#if 0 /* Maybe allow section after data2 - does this ever happen? */ + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + if (NEW_PROGRAM_H (n).p_vaddr + && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) + NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; + + if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) + NEW_PROGRAM_H (n).p_offset += new_data2_size; + } +#endif + + /* Fix up section headers based on new .data2 section. Any section + * whose offset or virtual address is after the new .data2 section + * gets its value adjusted. .bss size becomes zero and new address + * is set. data2 section header gets added by copying the existing + * .data header and modifying the offset, address and size. + */ + for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum; + old_data_index++) + if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, + ".data")) + break; + if (old_data_index == old_file_h->e_shnum) + fatal ("Can't find .data in %s.\n", old_name, 0); + + /* Walk through all section headers, insert the new data2 section right + before the new bss section. */ + for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++) + { + caddr_t src; + /* If it is bss section, insert the new data2 section before it. */ + if (n == old_bss_index) + { + /* Steal the data section header for this data2 section. */ + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), + new_file_h->e_shentsize); + + NEW_SECTION_H (nn).sh_addr = new_data2_addr; + NEW_SECTION_H (nn).sh_offset = new_data2_offset; + NEW_SECTION_H (nn).sh_size = new_data2_size; + /* Use the bss section's alignment. This will assure that the + new data2 section always be placed in the same spot as the old + bss section by any other application. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; + + /* Now copy over what we have in the memory now. */ + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, + (caddr_t) OLD_SECTION_H (n).sh_addr, + new_data2_size); + nn++; + } + + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* The new bss section's size is zero, and its file offset and virtual + address should be off by NEW_DATA2_SIZE. */ + if (n == old_bss_index) + { + /* NN should be `old_bss_index + 1' at this point. */ + NEW_SECTION_H (nn).sh_offset += new_data2_size; + NEW_SECTION_H (nn).sh_addr += new_data2_size; + /* Let the new bss section address alignment be the same as the + section address alignment followed the old bss section, so + this section will be placed in exactly the same place. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; + NEW_SECTION_H (nn).sh_size = 0; + } + else + { + /* Any section that was original placed AFTER the bss + section should now be off by NEW_DATA2_SIZE. */ +#ifdef SOLARIS_POWERPC + /* On PPC Reference Platform running Solaris 2.5.1 + the plt section is also of type NOBI like the bss section. + (not really stored) and therefore sections after the bss + section start at the plt offset. The plt section is always + the one just before the bss section. + It would be better to put the new data section before + the .plt section, or use libelf instead. + Erik Deumens, deumens@qtp.ufl.edu. */ + if (NEW_SECTION_H (nn).sh_offset + >= OLD_SECTION_H (old_bss_index-1).sh_offset) + NEW_SECTION_H (nn).sh_offset += new_data2_size; +#else + if (round_up (NEW_SECTION_H (nn).sh_offset, + OLD_SECTION_H (old_bss_index).sh_addralign) + >= new_data2_offset) + NEW_SECTION_H (nn).sh_offset += new_data2_size; +#endif + /* Any section that was originally placed after the section + header table should now be off by the size of one section + header table entry. */ + if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff) + NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize; + } + + /* If any section hdr refers to the section after the new .data + section, make it refer to next one because we have inserted + a new section in between. */ + + PATCH_INDEX (NEW_SECTION_H (nn).sh_link); + /* For symbol tables, info is a symbol table index, + so don't change it. */ + if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB + && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) + PATCH_INDEX (NEW_SECTION_H (nn).sh_info); + + /* Now, start to copy the content of sections. */ + if (NEW_SECTION_H (nn).sh_type == SHT_NULL + || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) + continue; + + /* Write out the sections. .data and .data1 (and data2, called + ".data" in the strings table) get copied from the current process + instead of the old file. */ + if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") + || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name), + ".data1")) + src = (caddr_t) OLD_SECTION_H (n).sh_addr; + else + src = old_base + OLD_SECTION_H (n).sh_offset; + + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, + NEW_SECTION_H (nn).sh_size); + + /* If it is the symbol table, its st_shndx field needs to be patched. */ + if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB + || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) + { + Elf32_Shdr *spt = &NEW_SECTION_H (nn); + unsigned int num = spt->sh_size / spt->sh_entsize; + Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + + new_base); + for (; num--; sym++) + { + if ((sym->st_shndx == SHN_UNDEF) + || (sym->st_shndx == SHN_ABS) + || (sym->st_shndx == SHN_COMMON)) + continue; + + PATCH_INDEX (sym->st_shndx); + } + } + } + + /* Update the symbol values of _edata and _end. */ + for (n = new_file_h->e_shnum - 1; n; n--) + { + byte *symnames; + Elf32_Sym *symp, *symendp; + + if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM + && NEW_SECTION_H (n).sh_type != SHT_SYMTAB) + continue; + + symnames = ((byte *) new_base + + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset); + symp = (Elf32_Sym *) (NEW_SECTION_H (n).sh_offset + new_base); + symendp = (Elf32_Sym *) ((byte *)symp + NEW_SECTION_H (n).sh_size); + + for (; symp < symendp; symp ++) + if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0 + || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0) + memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr)); + } + + /* This loop seeks out relocation sections for the data section, so + that it can undo relocations performed by the runtime linker. */ + for (n = new_file_h->e_shnum - 1; n; n--) + { + Elf32_Shdr section = NEW_SECTION_H (n); + switch (section.sh_type) { + default: + break; + case SHT_REL: + case SHT_RELA: + /* This code handles two different size structs, but there should + be no harm in that provided that r_offset is always the first + member. */ + nn = section.sh_info; + if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".data1")) + { + Elf32_Addr offset = NEW_SECTION_H (nn).sh_addr - + NEW_SECTION_H (nn).sh_offset; + caddr_t reloc = old_base + section.sh_offset, end; + for (end = reloc + section.sh_size; reloc < end; + reloc += section.sh_entsize) + { + Elf32_Addr addr = ((Elf32_Rel *) reloc)->r_offset - offset; + memcpy (new_base + addr, old_base + addr, 4); + } + } + break; + } + } + +#ifdef UNEXEC_USE_MAP_PRIVATE + if (lseek (new_file, 0, SEEK_SET) == -1) + fatal ("Can't rewind (%s): errno %d\n", new_name, errno); + + if (write (new_file, new_base, new_file_size) != new_file_size) + fatal ("Can't write (%s): errno %d\n", new_name, errno); +#endif + + /* Close the files and make the new file executable. */ + + if (close (old_file)) + fatal ("Can't close (%s): errno %d\n", old_name, errno); + + if (close (new_file)) + fatal ("Can't close (%s): errno %d\n", new_name, errno); + + if (stat (new_name, &stat_buf) == -1) + fatal ("Can't stat (%s): errno %d\n", new_name, errno); + + n = umask (777); + umask (n); + stat_buf.st_mode |= 0111 & ~n; + if (chmod (new_name, stat_buf.st_mode) == -1) + fatal ("Can't chmod (%s): errno %d\n", new_name, errno); +} @@ -0,0 +1,2000 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 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. + */ + +/* "unif.c" Uniform vectors and arrays + Authors: Aubrey Jaffer & Radey Shouman. + +The set of uniform vector types is: + Vector of: Called: +char string +boolean bvect +signed int ivect +unsigned int uvect +float fvect +double dvect +complex double cvect +*/ + +#include "scm.h" + +#ifndef STDC_HEADERS + int ungetc P((int c, FILE *stream)); + sizet fwrite (); +#endif + +long tc16_array = 0; + +char s_resizuve[] = "vector-set-length!"; +SCM resizuve(vect, len) + SCM vect, len; +{ + long l = INUM(len); + sizet siz, sz; + ASRTGO(NIMP(vect), badarg1); + switch TYP7(vect) { + default: badarg1: wta(vect, (char *)ARG1, s_resizuve); + case tc7_string: + ASRTGO(vect != nullstr, badarg1); + sz = sizeof(char); + l++; + break; + case tc7_vector: + ASRTGO(vect != nullvect, badarg1); + sz = sizeof(SCM); + break; +#ifdef ARRAYS + case tc7_bvect: + l = (l+LONG_BIT-1)/LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case tc7_cvect: + sz = 2*sizeof(double); + break; +# endif +#endif + } + ASSERT(INUMP(len), len, ARG2, s_resizuve); + if (!l) l = 1L; + siz = l * sz; + if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve); + DEFER_INTS; + SETCHARS(vect, (char *)must_realloc((char *)CHARS(vect), + (long)LENGTH(vect)*sz, + (long)siz, s_resizuve)); + if VECTORP(vect) { + sz = LENGTH(vect); + while(l > sz) VELTS(vect)[--l] = UNSPECIFIED; + } + else if STRINGP(vect) CHARS(vect)[l-1] = 0; + SETLENGTH(vect, INUM(len), TYP7(vect)); + ALLOW_INTS; + return vect; +} + +#ifdef ARRAYS + +# ifdef FLOATS +# ifdef SINGLES +SCM makflo (x) + float x; +{ + SCM z; + if (x==0.0) return flo0; + NEWCELL(z); + DEFER_INTS; + CAR(z) = tc_flo; + FLO(z) = x; + ALLOW_INTS; + return z; +} +# endif +# endif + +SCM make_uve(k, prot) + long k; + SCM prot; +{ + SCM v; + long i, type; + if (BOOL_T==prot) { + i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT); + type = tc7_bvect; + } + else if ICHRP(prot) { + i = sizeof(char)*k; + type = tc7_string; + } + else if INUMP(prot) { + i = sizeof(long)*k; + if (INUM(prot)>0) type = tc7_uvect; + else type = tc7_ivect; + } + else +# ifdef FLOATS + if (IMP(prot) || !INEXP(prot)) +# endif + /* Huge non-unif vectors are NOT supported. */ + return make_vector(MAKINUM(k), UNDEFINED); /* no special vector */ +# ifdef FLOATS +# ifdef SINGLES + else if SINGP(prot) { +# ifdef CDR_DOUBLES + double x = FLO(prot); + float fx = x; + if (x != fx) { + i = sizeof(double)*k; + type = tc7_dvect; + } + else +# endif + { + i = sizeof(float)*k; + type = tc7_fvect; + } + } +# endif + else if (CPLXP(prot)) { + i = 2*sizeof(double)*k; + type = tc7_cvect; + } + else { + i = sizeof(double)*k; + type = tc7_dvect; + } +# endif + + NEWCELL(v); + DEFER_INTS; + SETCHARS(v, must_malloc((i ? i : 1L), s_vector)); + SETLENGTH(v, (k<LENGTH_MAX ? k : LENGTH_MAX), type); + ALLOW_INTS; + return v; +} + +static char s_uve_len[] = "uniform-vector-length"; +SCM uve_len(v) + SCM v; +{ + ASRTGO(NIMP(v), badarg1); + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_uve_len); + case tc7_bvect: + case tc7_string: + case tc7_uvect: + case tc7_ivect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + case tc7_vector: + return MAKINUM(LENGTH(v)); + } +} + +SCM arrayp(v, prot) + SCM v, prot; +{ + int nprot = UNBNDP(prot), enclosed = 0; + if IMP(v) return BOOL_F; + loop: + switch TYP7(v) { + case tc7_smob: if (!ARRAYP(v)) return BOOL_F; + if (nprot) return BOOL_T; + if (enclosed++) return BOOL_F; + v = ARRAY_V(v); + goto loop; + case tc7_bvect: return nprot || BOOL_T==prot ? BOOL_T : BOOL_F; + case tc7_string: return nprot || ICHRP(prot) ? BOOL_T : BOOL_F; + case tc7_uvect: + return nprot || (INUMP(prot) && INUM(prot)>0) ? BOOL_T : BOOL_F; + case tc7_ivect: + return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F; +# endif + case tc7_dvect: return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F; + case tc7_cvect: return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F; +# endif + case tc7_vector: return nprot || NULLP(prot) ? BOOL_T : BOOL_F; + default:; + } + return BOOL_F; +} +SCM array_rank(ra) + SCM ra; +{ + if IMP(ra) return INUM0; + switch (TYP7(ra)) { + default: return INUM0; + case tc7_string: case tc7_vector: case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_fvect: + case tc7_cvect: case tc7_dvect: + return MAKINUM(1L); + case tc7_smob: + if ARRAYP(ra) return MAKINUM(ARRAY_NDIM(ra)); + return INUM0; + } +} +static char s_array_dims[] = "array-dimensions"; +SCM array_dims(ra) + SCM ra; +{ + SCM res=EOL; + sizet k; + array_dim *s; + if IMP(ra) return BOOL_F; + switch (TYP7(ra)) { + default: return BOOL_F; + case tc7_string: case tc7_vector: case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_fvect: + case tc7_cvect: case tc7_dvect: + return cons(MAKINUM(LENGTH(ra)), EOL); + case tc7_smob: + if (!ARRAYP(ra)) return BOOL_F; + k = ARRAY_NDIM(ra); + s = ARRAY_DIMS(ra); + while (k--) + res = cons(s[k].lbnd ? cons2(MAKINUM(s[k].lbnd), MAKINUM(s[k].ubnd), EOL) : + MAKINUM(1+(s[k].ubnd)) + , res); + return res; + } +} +static char s_bad_ind[] = "Bad array index"; +long aind(ra, args, what) + SCM ra, args; + char *what; +{ + SCM ind; + register long j; + register sizet pos = ARRAY_BASE(ra); + register sizet k = ARRAY_NDIM(ra); + array_dim *s = ARRAY_DIMS(ra); + if INUMP(args) { + ASSERT(1==k, UNDEFINED, WNA, what); + j = INUM(args); + ASSERT(j >= (s->lbnd) && j <= (s->ubnd), args, OUTOFRANGE, what); + return pos + (j - s->lbnd)*(s->inc); + } + ASSERT((IMP(args) ? NULLP(args) : CONSP(args)), args, s_bad_ind, what); + while (k && NIMP(args)) { + ind = CAR(args); + args = CDR(args); + ASSERT(INUMP(ind), ind, s_bad_ind, what); + j = INUM(ind); + ASSERT(j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what); + pos += (j - s->lbnd)*(s->inc); + k--; + s++; + } + ASSERT(0==k && NULLP(args), UNDEFINED, WNA, what); + return pos; +} + +SCM make_ra(ndim) + int ndim; +{ + SCM ra; + NEWCELL(ra); + DEFER_INTS; + SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)), + "array")); + CAR(ra) = ((long)ndim << 17) + tc16_array; + ARRAY_V(ra) = nullvect; + ALLOW_INTS; + return ra; +} + +static char s_bad_spec[] = "Bad array dimension"; +/* Increments will still need to be set. */ +SCM shap2ra(args, what) + SCM args; + char *what; +{ + array_dim *s; + SCM ra, spec, sp; + int ndim = ilength(args); + ASSERT(0 <= ndim, args, s_bad_spec, what); + ra = make_ra(ndim); + ARRAY_BASE(ra) = 0; + s = ARRAY_DIMS(ra); + for (; NIMP(args); s++, args = CDR(args)) { + spec = CAR(args); + if IMP(spec) { + ASSERT(INUMP(spec)&&INUM(spec)>=0, spec, s_bad_spec, what); + s->lbnd = 0; + s->ubnd = INUM(spec) - 1; + s->inc = 1; + } + else { + ASSERT(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what); + s->lbnd = INUM(CAR(spec)); + sp = CDR(spec); + ASSERT(INUMP(CAR(sp)) && NULLP(CDR(sp)), + spec, s_bad_spec, what); + s->ubnd = INUM(CAR(sp)); + s->inc = 1; + } + } + return ra; +} + +static char s_uve_fill[] = "uniform-vector-fill!"; +int rafill(ra, fill, ignore) + SCM ra, fill, ignore; +{ + sizet i, n; + long inc = 1; + sizet base = 0; + if ARRAYP(ra) { + n = ARRAY_DIMS(ra)->ubnd - ARRAY_DIMS(ra)->lbnd + 1; + inc = ARRAY_DIMS(ra)->inc; + base = ARRAY_BASE(ra); + ra = ARRAY_V(ra); + } + else + n = LENGTH(ra); + switch TYP7(ra) { + badarg2: wta(fill, (char *)ARG2, s_uve_fill); + default: ASSERT(NFALSEP(arrayp(ra, UNDEFINED)), ra, ARG1, s_uve_fill); + for (i = base; n--; i += inc) + aset(ra, fill, MAKINUM(i)); + break; + case tc7_vector: { + SCM *ve = VELTS(ra); + for (i = base; n--; i += inc) + ve[i] = fill; + break; + } + case tc7_string: { + char *ve = CHARS(ra); + SCM f = ICHR(fill); + ASRTGO(ICHRP(fill), badarg2); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } + case tc7_bvect: { + long *ve = (long *)VELTS(ra); + if (1==inc && (n >= LONG_BIT || n==LENGTH(ra))) { + i = base/LONG_BIT; + if (BOOL_F==fill) { + if (base % LONG_BIT) /* leading partial word */ + ve[i++] &= ~(~0L << (base % LONG_BIT)); + for (; i < (base + n)/LONG_BIT; i++) + ve[i] = 0L; + if ((base + n) % LONG_BIT) /* trailing partial word */ + ve[i] &= (~0L << ((base + n) % LONG_BIT)); + } + else if (BOOL_T==fill) { + if (base % LONG_BIT) + ve[i++] |= ~0L << (base % LONG_BIT); + for (; i < (base + n)/LONG_BIT; i++) + ve[i] = ~0L; + if ((base + n) % LONG_BIT) + ve[i] |= ~(~0L << ((base + n) % LONG_BIT)); + } + else goto badarg2; + } + else { + if (BOOL_F==fill) + for (i = base; n--; i += inc) + ve[i/LONG_BIT] &= ~(1L<<(i%LONG_BIT)); + else if (BOOL_T==fill) + for (i = base; n--; i += inc) + ve[i/LONG_BIT] |= (1L<<(i%LONG_BIT)); + else goto badarg2; + } + break; + } + case tc7_uvect: + case tc7_ivect: + { + long *ve = VELTS(ra); + long f = (tc7_uvect==TYP7(ra) ? + num2ulong(fill, (char *)ARG2, s_uve_fill) : + num2long(fill, (char *)ARG2, s_uve_fill)); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *ve = (float *)VELTS(ra); + float f = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } +# endif /* SINGLES */ + case tc7_dvect: { + double *ve = (double *)VELTS(ra); + double f = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) + ve[i] = f; + break; + } + case tc7_cvect: { + double fr, fi=0.0; + double (*ve)[2] = (double (*)[2])VELTS(ra); + if (NIMP(fill) && CPLXP(fill)) { + fr = REAL(fill); + fi = IMAG(fill); + } + else + fr = num2dbl(fill, (char *)ARG2, s_uve_fill); + for (i = base; n--; i += inc) { + ve[i][0] = fr; + ve[i][1] = fi; + } + break; + } +# endif /* FLOATS */ + } + return 1; +} +SCM uve_fill(uve, fill) + SCM uve, fill; +{ + + ASSERT(NIMP(uve) && (!ARRAYP(uve) || 1==ARRAY_NDIM(uve)), + uve, ARG1, s_uve_fill); + rafill(uve, fill, EOL); + return UNSPECIFIED; +} + +static char s_dims2ura[] = "dimensions->uniform-array"; +SCM dims2ura(dims, prot, fill) + SCM dims, prot, fill; +{ + sizet k, vlen = 1; + long rlen = 1; + array_dim *s; + SCM ra; + if INUMP(dims) + if (INUM(dims) < LENGTH_MAX) { + ra = make_uve(INUM(dims), prot); + if NNULLP(fill) + rafill(ra, CAR(fill), EOL); + return ra; + } + else + dims = cons(dims, EOL); + ASSERT(NULLP(dims) || (NIMP(dims) && CONSP(dims)), dims, ARG1, s_dims2ura); + ra = shap2ra(dims, s_dims2ura); + CAR(ra) |= ARRAY_CONTIGUOUS; + s = ARRAY_DIMS(ra); + k = 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 < LENGTH_MAX) + ARRAY_V(ra) = make_uve((rlen > 0 ? rlen : 0L), prot); + else { + sizet bit; + switch TYP7(make_uve(0L, prot)) { + default: bit = LONG_BIT; break; + case tc7_vector: wta(dims, (char *)OUTOFRANGE, s_dims2ura); + case tc7_bvect: bit = 1; break; + case tc7_string: bit = CHAR_BIT; break; + case tc7_fvect: bit = sizeof(float)*CHAR_BIT/sizeof(char); break; + case tc7_dvect: bit = sizeof(double)*CHAR_BIT/sizeof(char); break; + case tc7_cvect: bit = 2*sizeof(double)*CHAR_BIT/sizeof(char); break; + } + ARRAY_BASE(ra) = (LONG_BIT + bit - 1)/bit; + rlen += ARRAY_BASE(ra); + ARRAY_V(ra) = make_uve(rlen, prot); + *((long *)VELTS(ARRAY_V(ra))) = rlen; + } + if NNULLP(fill) { + ASSERT(1==ilength(fill), UNDEFINED, WNA, s_dims2ura); + rafill(ARRAY_V(ra), CAR(fill), EOL); + } + if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) + if (s->ubnd < s->lbnd || (0==s->lbnd && 1==s->inc)) return ARRAY_V(ra); + return ra; +} + +void ra_set_contp(ra) + SCM ra; +{ + sizet k = ARRAY_NDIM(ra); + long inc; + if (k) inc = ARRAY_DIMS(ra)[k-1].inc; + while (k--) { + if (inc != ARRAY_DIMS(ra)[k].inc) { + CAR(ra) &= ~ARRAY_CONTIGUOUS; + return; + } + inc *= (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1); + } + CAR(ra) |= ARRAY_CONTIGUOUS; +} +char s_make_sh_array[] = "make-shared-array"; +SCM make_sh_array(oldra, mapfunc, dims) + SCM oldra; + SCM mapfunc; + SCM dims; +{ + SCM ra; + SCM inds, indptr; + SCM imap; + sizet i, k; + long old_min, new_min, old_max, new_max; + array_dim *s; + ASSERT(BOOL_T==procedurep(mapfunc), mapfunc, ARG2, s_make_sh_array); + ASSERT(NIMP(oldra) && arrayp(oldra, UNDEFINED), oldra, ARG1, s_make_sh_array); + ra = shap2ra(dims, s_make_sh_array); + if (ARRAYP(oldra)) { + ARRAY_V(ra) = ARRAY_V(oldra); + old_min = old_max = ARRAY_BASE(oldra); + s=ARRAY_DIMS(oldra); + k = 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 { + ARRAY_V(ra) = oldra; + old_min = 0; + old_max = (long)LENGTH(oldra) - 1; + } + inds = EOL; + s = ARRAY_DIMS(ra); + for (k = 0; k < ARRAY_NDIM(ra); k++) { + inds = cons(MAKINUM(s[k].lbnd), inds); + if (s[k].ubnd < s[k].lbnd) { + if (1==ARRAY_NDIM(ra)) + ra = make_uve(0L, array_prot(ra)); + else + ARRAY_V(ra) = make_uve(0L, array_prot(ra)); + return ra; + } + } + imap = apply(mapfunc, reverse(inds), EOL); + if ARRAYP(oldra) + i = (sizet)aind(oldra, imap, s_make_sh_array); + else { + if NINUMP(imap) { + ASSERT(1==ilength(imap) && INUMP(CAR(imap)), + imap, s_bad_ind, s_make_sh_array); + imap = CAR(imap); + } + i = INUM(imap); + } + ARRAY_BASE(ra) = new_min = new_max = i; + indptr = inds; + k = ARRAY_NDIM(ra); + while (k--) { + if (s[k].ubnd > s[k].lbnd) { + CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1); + imap = apply(mapfunc, reverse(inds), EOL); + if ARRAYP(oldra) + s[k].inc = aind(oldra, imap, s_make_sh_array) - i; + else { + if NINUMP(imap) { + ASSERT(1==ilength(imap) && INUMP(CAR(imap)), + imap, s_bad_ind, s_make_sh_array); + imap = CAR(imap); + } + s[k].inc = (long)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 = CDR(indptr); + } + ASSERT(old_min <= new_min && old_max >= new_max, UNDEFINED, + "mapping out of range", s_make_sh_array); + if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) { + if (1==s->inc && 0==s->lbnd + && LENGTH(ARRAY_V(ra))==1+s->ubnd) return ARRAY_V(ra); + if (s->ubnd < s->lbnd) return make_uve(0L, array_prot(ra)); + } + ra_set_contp(ra); + return ra; +} + +/* args are RA . DIMS */ +static char s_trans_array[] = "transpose-array"; +SCM trans_array(args) + SCM args; +{ + SCM ra, res, vargs, *ve = &vargs; + array_dim *s, *r; + int ndim, i, k; + ASSERT(NIMP(args), UNDEFINED, WNA, s_trans_array); + ra = CAR(args); + args = CDR(args); + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_trans_array); + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array); + ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array); + return ra; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + vargs = vector(args); + ASSERT(LENGTH(vargs)==ARRAY_NDIM(ra), UNDEFINED, WNA, s_trans_array); + ve = VELTS(vargs); + ndim = 0; + for (k = 0; k < ARRAY_NDIM(ra); k++) { + i = INUM(ve[k]); + ASSERT(INUMP(ve[k]) && i >=0 && i < ARRAY_NDIM(ra), + ve[k], ARG2, s_trans_array); + if (ndim < i) ndim = i; + } + ndim++; + res = make_ra(ndim); + ARRAY_V(res) = ARRAY_V(ra); + ARRAY_BASE(res) = ARRAY_BASE(ra); + for (k = ndim; k--;) { + ARRAY_DIMS(res)[k].lbnd = 0; + ARRAY_DIMS(res)[k].ubnd = -1; + } + for (k = ARRAY_NDIM(ra); k--;) { + i = INUM(ve[k]); + s = &(ARRAY_DIMS(ra)[k]); + r = &(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) { + ARRAY_BASE(res) += (s->lbnd - r->lbnd)*r->inc; + r->lbnd = s->lbnd; + } + r->inc += s->inc; + } + } + ASSERT(ndim <= 0, args, "bad argument list", s_trans_array); + ra_set_contp(res); + return res; + } +} + +/* args are RA . AXES */ +static char s_encl_array[] = "enclose-array"; +SCM encl_array(axes) + SCM axes; +{ + SCM axv, ra, res, ra_inr; + array_dim vdim, *s = &vdim; + int ndim, j, k, ninr, noutr; + ASSERT(NIMP(axes), UNDEFINED, WNA, s_encl_array); + ra = CAR(axes); + axes = CDR(axes); + if NULLP(axes) + axes = cons((ARRAYP(ra) ? MAKINUM(ARRAY_NDIM(ra) - 1) : INUM0), EOL); + ninr = ilength(axes); + ra_inr = make_ra(ninr); + ASRTGO(NIMP(ra), badarg1); + switch TYP7(ra) { + default: badarg1: wta(ra, (char *)ARG1, s_encl_array); + case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + s->lbnd = 0; + s->ubnd = LENGTH(ra) - 1; + s->inc = 1; + ARRAY_V(ra_inr) = ra; + ARRAY_BASE(ra_inr) = 0; + ndim = 1; + break; + case tc7_smob: ASRTGO(ARRAYP(ra), badarg1); + s = ARRAY_DIMS(ra); + ARRAY_V(ra_inr) = ARRAY_V(ra); + ARRAY_BASE(ra_inr) = ARRAY_BASE(ra); + ndim = ARRAY_NDIM(ra); + break; + } + noutr = ndim - ninr; + axv = make_string(MAKINUM(ndim), MAKICHR(0)); + ASSERT(0 <= noutr && 0 <= ninr, UNDEFINED, WNA, s_encl_array); + res = make_ra(noutr); + ARRAY_BASE(res) = ARRAY_BASE(ra_inr); + ARRAY_V(res) = ra_inr; + for (k = 0; k < ninr; k++, axes = CDR(axes)) { + j = INUM(CAR(axes)); + ASSERT(INUMP(CAR(axes)) && j<ndim, CAR(axes), "bad axis", s_encl_array); + ARRAY_DIMS(ra_inr)[k].lbnd = s[j].lbnd; + ARRAY_DIMS(ra_inr)[k].ubnd = s[j].ubnd; + ARRAY_DIMS(ra_inr)[k].inc = s[j].inc; + CHARS(axv)[j] = 1; + } + for (j = 0, k = 0; k < noutr; k++, j++) { + while (CHARS(axv)[j]) j++; + ARRAY_DIMS(res)[k].lbnd = s[j].lbnd; + ARRAY_DIMS(res)[k].ubnd = s[j].ubnd; + ARRAY_DIMS(res)[k].inc = s[j].inc; + } + ra_set_contp(ra_inr); + ra_set_contp(res); + return res; +} + +static char s_array_inbp[] = "array-in-bounds?"; +SCM array_inbp(args) + SCM args; +{ + SCM v, ind = EOL; + register long j; + ASRTGO(NIMP(args), wna); + v = CAR(args); + args = CDR(args); + if IMP(v) goto scalar; + switch TYP7(v) { + default: + scalar: if NULLP(args) return BOOL_T; + badarg1: wta(v, (char *)ARG1, s_array_inbp); + wna: wta(UNDEFINED, (char *)WNA, s_array_inbp); + case tc7_smob: + if (ARRAYP(v)) { + SCM ret = BOOL_T; + register sizet k = ARRAY_NDIM(v); + array_dim *s = ARRAY_DIMS(v); + while (k && NIMP(args)) { + ind = CAR(args); + args = CDR(args); + ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp); + j = INUM(ind); + if (j < (s->lbnd) || j > (s->ubnd)) ret = BOOL_F; + k--; + s++; + } + ASRTGO(0==k && NULLP(args), wna); + return ret; + } + else goto scalar; + case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect: + case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector: + ASRTGO(NIMP(args) && NULLP(CDR(args)), wna); + ind = CAR(args); + ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp); + j = INUM(ind); + return j >= 0 && j < LENGTH(v) ? BOOL_T : BOOL_F; + } +} +static char s_aref[] = "array-ref"; +SCM aref(v, args) + SCM v, args; +{ + long pos; + if IMP(v) { + ASRTGO(NULLP(args), badarg); + return v; + } + else if ARRAYP(v) { + pos = aind(v, args, s_aref); + v = ARRAY_V(v); + } + else { + if NIMP(args) { + ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aref); + pos = INUM(CAR(args)); + ASRTGO(NULLP(CDR(args)), wna); + } + else { + ASSERT(INUMP(args), args, ARG2, s_aref); + pos = INUM(args); + } + ASRTGO(pos >= 0 && pos < LENGTH(v), outrng); + } + switch TYP7(v) { + default: if NULLP(args) return v; + badarg: wta(v, (char *)ARG1, s_aref); + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aref); + wna: wta(UNDEFINED, (char *)WNA, s_aref); + case tc7_smob: { /* enclosed */ + int k = ARRAY_NDIM(v); + SCM res = make_ra(k); + if (!ARRAYP(v)) { + ASRTGO(NULLP(args),badarg); + return v; + } + ARRAY_V(res) = ARRAY_V(v); + ARRAY_BASE(res) = pos; + while (k--) { + ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(v)[k].lbnd; + ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(v)[k].ubnd; + ARRAY_DIMS(res)[k].inc = ARRAY_DIMS(v)[k].inc; + } + return res; + } + case tc7_bvect: + if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT))) + return BOOL_T; + else return BOOL_F; + case tc7_string: + return MAKICHR(CHARS(v)[pos]); +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: + return MAKINUM(VELTS(v)[pos]); +# else + case tc7_uvect: + return ulong2num(VELTS(v)[pos]); + case tc7_ivect: + return long2num(VELTS(v)[pos]); +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + return makflo(((float *)CDR(v))[pos]); +# endif + case tc7_dvect: + return makdbl(((double *)CDR(v))[pos], 0.0); + case tc7_cvect: + return makdbl(((double *)CDR(v))[2*pos], + ((double *)CDR(v))[2*pos+1]); +# endif + case tc7_vector: + return VELTS(v)[pos]; + } +} +SCM scm_array_ref(args) + SCM args; +{ + ASSERT(NIMP(args), UNDEFINED, WNA, s_aref); + return aref(CAR(args), CDR(args)); +} + +/* Internal version of aref for uves that does no error checking and + tries to recycle conses. (Make *sure* you want them recycled.) */ +SCM cvref(v, pos, last) + SCM v; + sizet pos; + SCM last; +{ + switch TYP7(v) { + default: wta(v, (char *)ARG1, "PROGRAMMING ERROR: cvref"); + case tc7_bvect: + if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT))) + return BOOL_T; + else return BOOL_F; + case tc7_string: + return MAKICHR(CHARS(v)[pos]); +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: + return MAKINUM(VELTS(v)[pos]); +# else + case tc7_uvect: + return ulong2num(VELTS(v)[pos]); + case tc7_ivect: + return long2num(VELTS(v)[pos]); +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { + FLO(last) = ((float *)CDR(v))[pos]; + return last; + } + return makflo(((float *)CDR(v))[pos]); +# endif + case tc7_cvect: + if (0.0!=((double *)CDR(v))[2*pos+1]) { + if (NIMP(last) && tc_dblc==CAR(last)) { + REAL(last) = ((double *)CDR(v))[2*pos]; + IMAG(last) = ((double *)CDR(v))[2*pos+1]; + return last; + } + return makdbl(((double *)CDR(v))[2*pos], + ((double *)CDR(v))[2*pos+1]); + } + else pos *= 2; + /* Fall through */ + case tc7_dvect: +# ifdef CDR_DOUBLES + if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) { + FLO(last) = ((double *)CDR(v))[pos]; + return last; + } +# else +# ifdef SINGLES + if (NIMP(last) && tc_dblr==CAR(last)) +# else + if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last))) +# endif + { + REAL(last) = ((double *)CDR(v))[pos]; + return last; + } +# endif /* ndef CDR_DOUBLES */ + return makdbl(((double *)CDR(v))[pos], 0.0); +# endif /* def FLOATS */ + case tc7_vector: + return VELTS(v)[pos]; + case tc7_smob: { /* enclosed array */ + int k = ARRAY_NDIM(v); + if (IMP(last) || (!ARRAYP(last))) { + last = make_ra(k); + ARRAY_V(last) = ARRAY_V(v); + while (k--) { + ARRAY_DIMS(last)[k].ubnd = ARRAY_DIMS(v)[k].ubnd; + ARRAY_DIMS(last)[k].lbnd = ARRAY_DIMS(v)[k].lbnd; + ARRAY_DIMS(last)[k].inc = ARRAY_DIMS(v)[k].inc; + } + } + ARRAY_BASE(last) = pos; + return last; + } + } +} + +static char s_aset[] = "array-set!"; +SCM aset(v, obj, args) + SCM v, obj, args; +{ + long pos; + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + pos = aind(v, args, s_aset); + v = ARRAY_V(v); + } + else { + if NIMP(args) { + ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aset); + pos = INUM(CAR(args)); + ASRTGO(NULLP(CDR(args)), wna); + } + else { + ASSERT(INUMP(args), args, ARG2, s_aset); + pos = INUM(args); + } + ASRTGO(pos >= 0 && pos < LENGTH(v), outrng); + } + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_aset); + outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aset); + wna: wta(UNDEFINED, (char *)WNA, s_aset); + case tc7_smob: /* enclosed */ + goto badarg1; + case tc7_bvect: + if (BOOL_F==obj) + VELTS(v)[pos/LONG_BIT] &= ~(1L<<(pos%LONG_BIT)); + else if (BOOL_T==obj) + VELTS(v)[pos/LONG_BIT] |= (1L<<(pos%LONG_BIT)); + else badarg2: wta(obj, (char *)ARG2, s_aset); + break; + case tc7_string: + ASRTGO(ICHRP(obj), badarg2); + CHARS(v)[pos] = ICHR(obj); break; +# ifdef INUMS_ONLY + case tc7_uvect: + ASRTGO(INUM(obj) >= 0, badarg2); + case tc7_ivect: + ASRTGO(INUMP(obj), badarg2); VELTS(v)[pos] = INUM(obj); break; +# else + case tc7_uvect: + VELTS(v)[pos] = num2ulong(obj, (char *)ARG2, s_aset); break; + case tc7_ivect: + VELTS(v)[pos] = num2long(obj, (char *)ARG2, s_aset); break; +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + ((float*)VELTS(v))[pos] = (float)num2dbl(obj, (char *)ARG2, s_aset); break; +# endif + case tc7_dvect: + ((double*)VELTS(v))[pos] = num2dbl(obj, (char *)ARG2, s_aset); break; + case tc7_cvect: + if (NIMP(obj) && CPLXP(obj)) { + ((double *)CDR(v))[2*pos] = REALPART(obj); + ((double *)CDR(v))[2*pos+1] = IMAG(obj); + } + else { + ((double *)CDR(v))[2*pos] = num2dbl(obj, (char *)ARG2, s_aset); + ((double *)CDR(v))[2*pos+1] = 0.0; + } + break; +# endif + case tc7_vector: + VELTS(v)[pos] = obj; break; + } + return UNSPECIFIED; +} + +static char s_array_contents[] = "array-contents"; +SCM array_contents(ra, strict) + SCM ra, strict; +{ + SCM sra; + if IMP(ra) return BOOL_F; + switch TYP7(ra) { + default: + return BOOL_F; + case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect: + case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect: + return ra; + case tc7_smob: { + sizet k, ndim = ARRAY_NDIM(ra), len = 1; + if (!ARRAYP(ra) || !ARRAY_CONTP(ra)) return BOOL_F; + for (k = 0; k < ndim; k++) + len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1; + if (!UNBNDP(strict)) { + if (ndim && (1 != ARRAY_DIMS(ra)[ndim-1].inc)) return BOOL_F; + if (tc7_bvect==TYP7(ARRAY_V(ra))) { + if (ARRAY_BASE(ra)%LONG_BIT) return BOOL_F; + if (len != LENGTH(ARRAY_V(ra)) && len%LONG_BIT) return BOOL_F; + } + } + if ((len==LENGTH(ARRAY_V(ra))) && 0==ARRAY_BASE(ra) && ARRAY_DIMS(ra)->inc) + return ARRAY_V(ra); + sra = make_ra(1); + ARRAY_DIMS(sra)->lbnd = 0; + ARRAY_DIMS(sra)->ubnd = len - 1; + ARRAY_V(sra) = ARRAY_V(ra); + ARRAY_BASE(sra) = ARRAY_BASE(ra); + ARRAY_DIMS(sra)->inc = (ndim ? ARRAY_DIMS(ra)[ndim - 1].inc : 1); + return sra; + } + } +} + +static char s_uve_rd[] = "uniform-vector-read!"; +SCM uve_read(v, port) + SCM v, port; +{ + long sz, len, ans; + long start=0; + if UNBNDP(port) port = cur_inp; + else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd); + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + loop: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_uve_rd); + case tc7_smob: + v = array_contents(v, BOOL_T); + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + array_dim *d = ARRAY_DIMS(v); + start = ARRAY_BASE(v); + len = d->inc * (d->ubnd - d->lbnd + 1); + v = ARRAY_V(v); + } + else + len = LENGTH(v); + goto loop; + case tc7_string: + sz = sizeof(char); + break; + case tc7_bvect: + len = (len+LONG_BIT-1)/LONG_BIT; + start /= LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case 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 CRDYP(port) { /* UGGH!!! */ + ungetc(CGETUN(port), STREAM(port)); + CLRDY(port); /* Clear ungetted char */ + } + SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); + if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + return MAKINUM(ans); +} + +static char s_uve_wr[] = "uniform-vector-write"; +SCM uve_write(v, port) + SCM v, port; +{ + long sz, len, ans; + long start=0; + if UNBNDP(port) port = cur_outp; + else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr); + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + loop: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_uve_wr); + case tc7_smob: + v = array_contents(v, BOOL_T); + ASRTGO(NIMP(v), badarg1); + if ARRAYP(v) { + array_dim *d = ARRAY_DIMS(v); + start = ARRAY_BASE(v); + len = d->inc * (d->ubnd - d->lbnd + 1); + v = ARRAY_V(v); + } + else + len = LENGTH(v); + goto loop; + case tc7_string: + sz = sizeof(char); + break; + case tc7_bvect: + len = (len+LONG_BIT-1)/LONG_BIT; + start /= LONG_BIT; + case tc7_uvect: + case tc7_ivect: + sz = sizeof(long); + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + sz = sizeof(float); + break; +# endif + case tc7_dvect: + sz = sizeof(double); + break; + case tc7_cvect: + sz = 2*sizeof(double); + break; +# endif + } + SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port));); + if (TYP7(v)==tc7_bvect) ans *= LONG_BIT; + return MAKINUM(ans); +} + +static char cnt_tab[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; +static char s_count[] = "bit-count"; +SCM lcount(item, seq) + SCM item, seq; +{ + long i, imin, ubnd, lbnd = 0; + int enclosed = 0; + register unsigned long cnt = 0, w; + ASSERT(NIMP(seq), seq, ARG2, s_count); + ubnd = LENGTH(seq) - 1; + tail: + switch TYP7(seq) { + default: badarg2: wta(seq, (char *)ARG2, s_count); + case tc7_bvect: + if (lbnd>ubnd) return INUM0; + i = ubnd/LONG_BIT; + imin = lbnd/LONG_BIT; + w = VELTS(seq)[i]; + if FALSEP(item) w = ~w; + w <<= LONG_BIT-1-(ubnd%LONG_BIT); + w >>= LONG_BIT-1-(ubnd%LONG_BIT); /* There may be only a partial word. */ + while (imin < i--) { + for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + w = VELTS(seq)[i]; + if FALSEP(item) w = ~w; + } + w >>= (lbnd%LONG_BIT); + for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f]; + return MAKINUM(cnt); + case tc7_smob: + ASRTGO(ARRAYP(seq) && 1==ARRAY_NDIM(seq) && 0==enclosed++, badarg2); + { + long n, inc = ARRAY_DIMS(seq)->inc; + switch (inc) { + default: + i = ARRAY_BASE(seq); + n = ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd + 1; + if (n<=0) return INUM0; + seq = ARRAY_V(seq); + if FALSEP(item) + for (;n--; i+=inc) + if (!((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT)))) cnt++; + else + for (;n--; i+=inc) + if ((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT))) cnt++; + return MAKINUM(cnt); + case 1: + lbnd = ARRAY_BASE(seq); + ubnd = lbnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc; + seq = ARRAY_V(seq); + goto tail; + case -1: + ubnd = ARRAY_BASE(seq); + lbnd = ubnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc; + seq = ARRAY_V(seq); + goto tail; + } + } + } +} +static char s_uve_pos[] = "bit-position"; +SCM position(item, v, k) + SCM item, v, k; +{ + long i, len, lenw, xbits, pos = INUM(k), offset = 0; + int enclosed = 0; + register unsigned long w; + ASSERT(NIMP(v), v, ARG2, s_uve_pos); + ASSERT(INUMP(k), k, ARG3, s_uve_pos); + len = LENGTH(v); + tail: + switch TYP7(v) { + default: badarg2: wta(v, (char *)ARG2, s_uve_pos); + case tc7_bvect: + ASSERT((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos); + if (pos==len) return BOOL_F; + if (0==len) return MAKINUM(-1L); + lenw = (len-1)/LONG_BIT; /* watch for part words */ + i = pos/LONG_BIT; + w = VELTS(v)[i]; + if FALSEP(item) w = ~w; + xbits = (pos%LONG_BIT); + pos -= xbits; + w = ((w >> xbits) << xbits); + xbits = LONG_BIT-1-(len-1)%LONG_BIT; + while (!0) { + if (w && (i==lenw)) + w = ((w << xbits) >> xbits); + if (w) while (w) switch (w & 0x0f) + { + default: return MAKINUM(pos-offset); + case 2: case 6: case 10: case 14: return MAKINUM(pos+1-offset); + case 4: case 12: return MAKINUM(pos+2-offset); + case 8: return MAKINUM(pos+3-offset); + case 0: pos += 4; w >>= 4; + } + if (++i > lenw) break; + pos += LONG_BIT; + w = VELTS(v)[i]; + if FALSEP(item) w = ~w; + } + return BOOL_F; + case tc7_smob: ASRTGO(ARRAYP(v) && 1==ARRAY_NDIM(v) && !enclosed++, badarg2); + ASSERT(pos >= ARRAY_DIMS(v)->lbnd, k, OUTOFRANGE, s_uve_pos); + if (1==ARRAY_DIMS(v)->inc) { + len = ARRAY_DIMS(v)->ubnd - ARRAY_DIMS(v)->lbnd + ARRAY_BASE(v) + 1; + offset = ARRAY_BASE(v) - ARRAY_DIMS(v)->lbnd; + pos += offset; + v = ARRAY_V(v); + goto tail; + } + else { + long inc = ARRAY_DIMS(v)->inc; + long ubnd = ARRAY_DIMS(v)->ubnd; + if (ubnd < ARRAY_DIMS(v)->lbnd) + return MAKINUM(ARRAY_DIMS(v)->lbnd - 1); + i = ARRAY_BASE(v) + (pos - ARRAY_DIMS(v)->lbnd)*inc; + v = ARRAY_V(v); + for (; pos <= ubnd; pos++) { + if (item == + ((VELTS(v)[i/LONG_BIT])&(1L<<(i%LONG_BIT)) ? BOOL_T : BOOL_F)) + return MAKINUM(pos); + i += inc; + } + return BOOL_F; + } + } +} + +static char s_bit_set[] = "bit-set*!"; +SCM bit_set(v, kv, obj) + SCM v, kv, obj; +{ + register long i, k, vlen; + ASRTGO(NIMP(v), badarg1); + ASRTGO(NIMP(kv), badarg2); + switch TYP7(kv) { + default: badarg2: wta(kv, (char *)ARG2, s_bit_set); + case tc7_uvect: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_bit_set); + case tc7_bvect: + vlen = LENGTH(v); + if (BOOL_F==obj) for (i = LENGTH(kv);i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set); + VELTS(v)[k/LONG_BIT] &= ~(1L<<(k%LONG_BIT)); + } + else if (BOOL_T==obj) for (i = LENGTH(kv); i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set); + VELTS(v)[k/LONG_BIT] |= (1L<<(k%LONG_BIT)); + } + else + badarg3: wta(obj, (char *)ARG3, s_bit_set); + } + break; + case tc7_bvect: + ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + if (BOOL_F==obj) + for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] &= ~(VELTS(kv)[k]); + else if (BOOL_T==obj) + for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] |= VELTS(kv)[k]; + else goto badarg3; + break; + } + return UNSPECIFIED; +} + +static char s_bit_count[] = "bit-count*"; +SCM bit_count(v, kv, obj) + SCM v, kv, obj; +{ + register long i, vlen, count = 0; + register unsigned long k; + ASRTGO(NIMP(v), badarg1); + ASRTGO(NIMP(kv), badarg2); + switch TYP7(kv) { + default: badarg2: wta(kv, (char *)ARG2, s_bit_count); + case tc7_uvect: + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_bit_count); + case tc7_bvect: + vlen = LENGTH(v); + if (BOOL_F==obj) for (i = LENGTH(kv);i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count); + if (!(VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT)))) count++; + } + else if (BOOL_T==obj) for (i = LENGTH(kv); i;) { + k = VELTS(kv)[--i]; + ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count); + if (VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT))) count++; + } + else + badarg3: wta(obj, (char *)ARG3, s_bit_count); + } + break; + case tc7_bvect: + ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1); + if (0==LENGTH(v)) return INUM0; + ASRTGO(BOOL_T==obj || BOOL_F==obj, badarg3); + obj = (BOOL_T==obj); + i = (LENGTH(v)-1)/LONG_BIT; + k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); + k <<= LONG_BIT-1-((LENGTH(v)-1)%LONG_BIT); + while (!0) { + for(;k;k >>= 4) count += cnt_tab[k & 0x0f]; + if (0==i--) return MAKINUM(count); + k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]); + } + } + return MAKINUM(count); +} + +static char s_bit_inv[] = "bit-invert!"; +SCM bit_inv(v) + SCM v; +{ + register long k; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_bvect: + for (k = (k+LONG_BIT-1)/LONG_BIT;k--;) + VELTS(v)[k] = ~VELTS(v)[k]; + break; + default: badarg1: wta(v, (char *)ARG1, s_bit_inv); + } + return UNSPECIFIED; +} + +static char s_strup[] = "string-upcase!"; +SCM strup(v) + SCM v; +{ + register long k; + register unsigned char *cs; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_string: + cs = UCHARS(v); + while (k--) cs[k] = upcase[cs[k]]; + break; + default: badarg1: wta(v, (char *)ARG1, s_strup); + } + return v; +} + +static char s_strdown[] = "string-downcase!"; +SCM strdown(v) + SCM v; +{ + register long k; + register unsigned char *cs; + ASRTGO(NIMP(v), badarg1); + k = LENGTH(v); + switch TYP7(v) { + case tc7_string: + cs = UCHARS(v); + while (k--) cs[k] = downcase[cs[k]]; + break; + default: badarg1: wta(v, (char *)ARG1, s_strdown); + } + return v; +} + +# include <ctype.h> +static char s_strcap[] = "string-capitalize!"; +SCM strcap(v) + SCM v; +{ + long i = 0, len; + register unsigned char *str; + register int non_first_alpha = 0; + ASRTGO(NIMP(v), badarg1); + len = LENGTH(v); + switch TYP7(v) { + case tc7_string: + for (str = UCHARS(v);i < len; i++) { + int c = str[i]; + if (isascii(c) && isalpha(c)) + if (non_first_alpha) str[i] = downcase[c]; + else { + non_first_alpha = !0; + str[i] = upcase[c]; + } + else non_first_alpha = 0; + } + break; + default: badarg1: wta(v, (char *)ARG1, s_strcap); + } + return v; +} + +SCM istr2bve(str, len) + char *str; + long len; +{ + SCM v = make_uve(len, BOOL_T); + long *data = (long *)VELTS(v); + register unsigned long mask; + register long k; + register long j; + for (k = 0; k < (len+LONG_BIT-1)/LONG_BIT; k++) { + data[k] = 0L; + j = len - k*LONG_BIT; + if (j > LONG_BIT) j = LONG_BIT; + for (mask = 1L; j--; mask <<= 1) + switch (*str++) { + case '0': break; + case '1': data[k] |= mask; break; + default: return BOOL_F; + } + } + return v; +} + +static SCM ra2l(ra, base, k) + SCM ra; + sizet base; + sizet k; +{ + register SCM res = EOL; + register long inc = ARRAY_DIMS(ra)[k].inc; + register sizet i; + if (ARRAY_DIMS(ra)[k].ubnd < ARRAY_DIMS(ra)[k].lbnd) return EOL; + i = base + (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd)*inc; + if (k < ARRAY_NDIM(ra) - 1) { + do { + i -= inc; + res = cons(ra2l(ra, i, k+1), res); + } while (i != base); + } + else + do { + i -= inc; + res = cons(cvref(ARRAY_V(ra), i, UNDEFINED), res); + } while (i != base); + return res; +} + +static char s_array2list[] = "array->list"; +SCM array2list(v) + SCM v; +{ + SCM res = EOL; + register long k; + ASRTGO(NIMP(v), badarg1); + switch TYP7(v) { + default: badarg1: wta(v, (char *)ARG1, s_array2list); + case tc7_smob: ASRTGO(ARRAYP(v), badarg1); + return ra2l(v, ARRAY_BASE(v), 0); + case tc7_vector: return vector2list(v); + case tc7_string: return string2list(v); + case tc7_bvect: { + long *data = (long *)VELTS(v); + register unsigned long mask; + for (k = (LENGTH(v)-1)/LONG_BIT; k > 0; k--) + for (mask = 1L<<(LONG_BIT-1); mask; mask >>=1) + res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res); + for (mask = 1L<<((LENGTH(v)%LONG_BIT)-1); mask; mask >>=1) + res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res); + return res; + } +# ifdef INUMS_ONLY + case tc7_uvect: + case tc7_ivect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(MAKINUM(data[k]), res); + return res; + } +# else + case tc7_uvect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(ulong2num(data[k]), res); + return res; + } + case tc7_ivect: { + long *data = (long *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(long2num(data[k]), res); + return res; + } +# endif +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: { + float *data = (float *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makflo(data[k]), res); + return res; + } +# endif /*SINGLES*/ + case tc7_dvect: { + double *data = (double *)VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makdbl(data[k], 0.0), res); + return res; + } + case tc7_cvect: { + double (*data)[2] = (double (*)[2])VELTS(v); + for (k = LENGTH(v) - 1; k >= 0; k--) + res = cons(makdbl(data[k][0], data[k][1]), res); + return res; + } +# endif /*FLOATS*/ + } +} + +static int l2ra P((SCM lst, SCM ra, sizet base, sizet k)); +static char s_bad_ralst[] = "Bad array contents list"; +static char s_list2ura[] = "list->uniform-array"; +SCM list2ura(ndim, prot, lst) + SCM ndim; + SCM prot; + SCM lst; +{ + SCM shp=EOL; + SCM row=lst; + SCM ra; + sizet k; + long n; + ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura); + k = INUM(ndim); + for (; k--; NIMP(row) && (row = CAR(row))) { + n = ilength(row); + ASSERT(n>=0, lst, ARG2, s_list2ura); + shp = cons(MAKINUM(n), shp); + } + ra = dims2ura(reverse(shp), prot, EOL); + if NULLP(shp) { + ASRTGO(1==ilength(lst), badlst); + aset(ra, CAR(lst), EOL); + return ra; + } + if (!ARRAYP(ra)) { + for (k = 0; k < LENGTH(ra); k++, lst = CDR(lst)) + aset(ra, CAR(lst), MAKINUM(k)); + return ra; + } + if (l2ra(lst, ra, ARRAY_BASE(ra), 0)) + return ra; + else + badlst: wta(lst, s_bad_ralst, s_list2ura); + return BOOL_F; +} + +static int l2ra(lst, ra, base, k) + SCM lst; + SCM ra; + sizet base; + sizet k; +{ + register long inc = ARRAY_DIMS(ra)[k].inc; + register long n = (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd); + int ok = 1; + if (n <= 0) return (EOL==lst); + if (k < ARRAY_NDIM(ra) - 1) { + while (n--) { + if (IMP(lst) || NCONSP(lst)) return 0; + ok = ok && l2ra(CAR(lst), ra, base, k+1); + base += inc; + lst = CDR(lst); + } + if NNULLP(lst) return 0; + } + else { + while (n--) { + if (IMP(lst) || NCONSP(lst)) return 0; + ok = ok && aset(ARRAY_V(ra), CAR(lst), MAKINUM(base)); + base += inc; + lst = CDR(lst); + } + if NNULLP(lst) return 0; + } + return ok; +} + +static void rapr1(ra, j, k, port, writing) + SCM ra; + sizet j; + sizet k; + SCM port; + int writing; +{ + long inc = 1; + long n = LENGTH(ra); + int enclosed = 0; + tail: + switch TYP7(ra) { + case tc7_smob: + if (enclosed++) { + ARRAY_BASE(ra) = j; + if (n-- > 0) iprin1(ra, port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + ARRAY_BASE(ra) = j; + iprin1(ra, port, writing); + } + break; + } + if (k+1 < ARRAY_NDIM(ra)) { + long i; + inc = ARRAY_DIMS(ra)[k].inc; + for (i = ARRAY_DIMS(ra)[k].lbnd; i < ARRAY_DIMS(ra)[k].ubnd; i++) { + lputc('(', port); + rapr1(ra, j, k+1, port, writing); + lputs(") ", port); + j += inc; + } + if (i==ARRAY_DIMS(ra)[k].ubnd) { /* could be zero size. */ + lputc('(', port); + rapr1(ra, j, k+1, port, writing); + lputc(')', port); + } + break; + } + if ARRAY_NDIM(ra) { /* Could be zero-dimensional */ + inc = ARRAY_DIMS(ra)[k].inc; + n = (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1); + } + else + n = 1; + ra = ARRAY_V(ra); + goto tail; + default: + if (n-- > 0) iprin1(cvref(ra, j, UNDEFINED), port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(cvref(ra, j, UNDEFINED), port, writing); + } + break; + case tc7_string: + if (n-- > 0) iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + if (writing) + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(MAKICHR(CHARS(ra)[j]), port, writing); + } + else + for (j += inc; n-- > 0; j += inc) + lputc(CHARS(ra)[j], port); + break; + case tc7_uvect: + if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + iprin1(ulong2num(VELTS(ra)[j]), port, writing); + } + break; + case tc7_ivect: + if (n-- > 0) intprint(VELTS(ra)[j], 10, port); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + intprint(VELTS(ra)[j], 10, port); + } + break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: +# endif /*SINGLES*/ + case tc7_dvect: + case tc7_cvect: + if (n-- > 0) { + SCM z = cvref(ra, j, UNDEFINED); + floprint(z, port, writing); + for (j += inc; n-- > 0; j += inc) { + lputc(' ', port); + z = cvref(ra, j, z); + floprint(z, port, writing); + } + } + break; +# endif /*FLOATS*/ + } +} +int raprin1(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + SCM v = exp; + sizet base = 0; + lputc('#', port); + tail: + switch TYP7(v) { + case tc7_smob: { + long ndim = ARRAY_NDIM(v); + base = ARRAY_BASE(v); + v = ARRAY_V(v); + if ARRAYP(v) { + lputs("<enclosed-array ", port); + rapr1(exp, base, 0, port, writing); + lputc('>', port); + return 1; + } + else { + intprint(ndim, 10, port); + goto tail; + } + } + case tc7_bvect: + if (exp==v) { /* a uve, not an array */ + register long i, j, w; + lputc('*', port); + for(i = 0;i<(LENGTH(exp))/LONG_BIT;i++) { + w = VELTS(exp)[i]; + for(j = LONG_BIT;j;j--) { + lputc(w&1?'1':'0', port); + w >>= 1; + } + } + j = LENGTH(exp)%LONG_BIT; + if (j) { + w = VELTS(exp)[LENGTH(exp)/LONG_BIT]; + for(;j;j--) { + lputc(w&1?'1':'0', port); + w >>= 1; + } + } + return 1; + } + else + lputc('b', port); break; + case tc7_string: + lputc('a', port); break; + case tc7_uvect: + lputc('u', port); break; + case tc7_ivect: + lputc('e', port); break; +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: + lputc('s', port); break; +# endif /*SINGLES*/ + case tc7_dvect: + lputc('i', port); break; + case tc7_cvect: + lputc('c', port); break; +# endif /*FLOATS*/ + } + lputc('(', port); + rapr1(exp, base, 0, port, writing); + lputc(')', port); + return 1; +} + +static char s_array_prot[] = "array-prototype"; +SCM array_prot(ra) + SCM ra; +{ + int enclosed = 0; + ASRTGO(NIMP(ra), badarg); + loop: + switch TYP7(ra) { + default: badarg: wta(ra, (char *)ARG1, s_array_prot); + case tc7_smob: ASRTGO(ARRAYP(ra), badarg); + if (enclosed++) return UNSPECIFIED; + ra = ARRAY_V(ra); + goto loop; + case tc7_vector: return EOL; + case tc7_bvect: return BOOL_T; + case tc7_string: return MAKICHR('a'); + case tc7_uvect: return MAKINUM(1L); + case tc7_ivect: return MAKINUM(-1L); +# ifdef FLOATS +# ifdef SINGLES + case tc7_fvect: return makflo(1.0); +# endif + case tc7_dvect: return makdbl(1.0/3.0, 0.0); + case tc7_cvect: return makdbl(0.0, 1.0); +# endif + } +} + +static iproc subr3s[] = { + {"uniform-vector-set1!", aset}, + {s_uve_pos, position}, + {s_bit_set, bit_set}, + {s_bit_count, bit_count}, + {s_list2ura, list2ura}, + {0, 0}}; + +static iproc subr2s[] = { + {"uniform-vector-ref", aref}, + {s_resizuve, resizuve}, + {s_count, lcount}, + {s_uve_fill, uve_fill}, + {0, 0}}; + +static iproc subr1s[] = { + {"array-rank", array_rank}, + {s_array_dims, array_dims}, + {s_array2list, array2list}, + {s_uve_len, uve_len}, + {s_bit_inv, bit_inv}, + {s_strdown, strdown}, + {s_strcap, strcap}, + {s_strup, strup}, + {s_array_prot, array_prot}, + {0, 0}}; + +static iproc lsubrs[] = { + {s_aref, scm_array_ref}, + {s_trans_array, trans_array}, + {s_encl_array, encl_array}, + {s_array_inbp, array_inbp}, + {0, 0}}; + +static iproc lsubr2s[] = { + {s_make_sh_array, make_sh_array}, + {s_dims2ura, dims2ura}, + {s_aset, aset}, + {0, 0}}; + +static iproc subr2os[] = { + {"array?", arrayp}, + {s_array_contents, array_contents}, + {s_uve_rd, uve_read}, + {s_uve_wr, uve_write}, + {0, 0}}; + +static SCM markra(ptr) + SCM ptr; +{ + if GC8MARKP(ptr) return BOOL_F; + SETGC8MARK(ptr); + return ARRAY_V(ptr); +} +static sizet freera(ptr) + CELLPTR ptr; +{ + must_free(CHARS(ptr)); + return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim); +} +static smobfuns rasmob = {markra, freera, raprin1, 0}; + /* 0 replaced by raequal in init_ramap() */ + +/* This must be done after init_scl() */ +void init_unif() +{ + init_iprocs(subr3s, tc7_subr_3); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(lsubrs, tc7_lsubr); + init_iprocs(lsubr2s, tc7_lsubr_2); + init_iprocs(subr2os, tc7_subr_2o); + tc16_array = newsmob(&rasmob); + add_feature(s_array); + add_feature("string-case"); +} + +#else /* ARRAYS */ + +int raprin1(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ + return 0; +} + +SCM istr2bve(str, len) + char *str; + long len; +{ + return BOOL_F; +} + +SCM array_equal(ra0, ra1) + SCM ra0, ra1; +{ + return BOOL_F; +} + +void init_unif() +{ + make_subr(s_resizuve, tc7_subr_2, resizuve); +} + +#endif /* ARRAYS */ @@ -0,0 +1,151 @@ +/* Copyright (C) 1994, 1995 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "unix.c" functions only in Unix (unix). + Author: Aubrey Jaffer */ + +#include "scm.h" + +#include <pwd.h> +#include <sys/types.h> +/* #include <sys/wait.h> */ +#include <sys/stat.h> + +SCM stat2scm P((struct stat *stat_temp)); + +#ifndef STDC_HEADERS + void sync P((void)); + int symlink P((const char *oldpath, const char *newpath)); + int readlink P((const char *path, char *buf, sizet bufsiz)); + int acct P((const char *filename)); + int nice P((int inc)); +#endif /* STDC_HEADERS */ + + /* Only the superuser can successfully execute mknod and acct */ +/* int mknod P((const char *path, mode_t mode, dev_t dev)); + should be in stat.h */ +static char s_mknod[] = "mknod"; +SCM l_mknod(path, mode, dev) + SCM path, mode, dev; +{ + int val; + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mknod); + ASSERT(INUMP(mode), mode, ARG2, s_mknod); + ASSERT(INUMP(dev), dev, ARG3, s_mknod); + SYSCALL(val = mknod(CHARS(path), INUM(mode), INUM(dev));); + return val ? BOOL_F : BOOL_T; +} +static char s_acct[] = "acct"; +SCM l_acct(path) + SCM path; +{ + int val; + if FALSEP(path) { + SYSCALL(val = acct(0);); + return val ? BOOL_F : BOOL_T; + } + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_acct); + SYSCALL(val = acct(CHARS(path));); + return val ? BOOL_F : BOOL_T; +} + +static char s_nice[] = "nice"; +SCM l_nice(incr) + SCM incr; +{ + ASSERT(INUMP(incr), incr, ARG1, s_nice); + return nice(INUM(incr)) ? BOOL_F : BOOL_T; +} + +SCM l_sync() +{ + sync(); + return UNSPECIFIED; +} + +static char s_symlink[] = "symlink"; +SCM l_symlink(oldpath, newpath) + SCM oldpath, newpath; +{ + int val; + ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_symlink); + ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_symlink); + SYSCALL(val = symlink(CHARS(oldpath), CHARS(newpath));); + return val ? BOOL_F : BOOL_T; +} +static char s_readlink[] = "readlink"; +SCM l_readlink(path) + SCM path; +{ + int i; + char buf[1024]; + ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_readlink); + SYSCALL(i = readlink(CHARS(path), buf, (sizet)sizeof(buf));); + if (-1==i) return BOOL_F; + return makfromstr(buf, (sizet)i); +} +static char s_lstat[] = "lstat"; +SCM l_lstat(str) + SCM str; +{ + int i; + struct stat stat_temp; + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_lstat); + SYSCALL(i = lstat(CHARS(str), &stat_temp);); + if (i) return BOOL_F; + return stat2scm(&stat_temp); +} + +static iproc subr1s[] = { + {s_nice, l_nice}, + {s_acct, l_acct}, + {s_lstat, l_lstat}, + {s_readlink, l_readlink}, + {0, 0}}; + +void init_unix() +{ + make_subr("sync", tc7_subr_0, l_sync); + init_iprocs(subr1s, tc7_subr_1); + make_subr(s_symlink, tc7_subr_2, l_symlink); + make_subr(s_mknod, tc7_subr_3, l_mknod); + add_feature("unix"); +} |