From 5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:23 -0800 Subject: Import Upstream version 4e6 --- ANNOUNCE | 218 ++ COPYING | 339 +++ ChangeLog | 3029 +++++++++++++++++++++ Iedline.scm | 103 + Init.scm | 854 ++++++ Link.scm | 284 ++ Makefile | 384 +++ Makefile.in | 462 ++++ QUICKREF | 201 ++ README | 384 +++ README.unix | 182 ++ Transcen.scm | 133 + acconfig-1.5.h | 22 + bench.scm | 55 + build.bat | 1 + build.scm | 1393 ++++++++++ configure | 849 ++++++ configure.in | 33 + continue.c | 255 ++ continue.h | 178 ++ crs.c | 412 +++ dynl.c | 448 ++++ ecrt0.c | 614 +++++ edline.c | 94 + eval.c | 1494 +++++++++++ example.scm | 137 + findexec.c | 145 + gmalloc.c | 1638 ++++++++++++ gsubr.c | 138 + install-sh | 238 ++ ioext.c | 703 +++++ mkinstalldirs | 35 + patchlvl.h | 8 + pi.c | 78 + pi.scm | 165 ++ posix.c | 408 +++ pre-crt0.c | 9 + r4rstest.scm | 1038 ++++++++ ramap.c | 1677 ++++++++++++ record.c | 349 +++ repl.c | 1649 ++++++++++++ rgx.c | 661 +++++ rope.c | 335 +++ sc2.c | 172 ++ scl.c | 2393 +++++++++++++++++ scm.1 | 335 +++ scm.c | 940 +++++++ scm.doc | 330 +++ scm.h | 817 ++++++ scm.texi | 6911 ++++++++++++++++++++++++++++++++++++++++++++++++ scm4e3.scmconfig.patch | 60 + scmconfig.h.in | 69 + scmfig.h | 671 +++++ setjump.h | 122 + setjump.mar | 38 + setjump.s | 40 + socket.c | 635 +++++ split.scm | 87 + subr.c | 2009 ++++++++++++++ sys.c | 1758 ++++++++++++ time.c | 389 +++ unexec.c | 1238 +++++++++ unexelf.c | 908 +++++++ unif.c | 2000 ++++++++++++++ unix.c | 151 ++ 65 files changed, 43905 insertions(+) create mode 100644 ANNOUNCE create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 Iedline.scm create mode 100644 Init.scm create mode 100644 Link.scm create mode 100644 Makefile create mode 100644 Makefile.in create mode 100644 QUICKREF create mode 100644 README create mode 100644 README.unix create mode 100644 Transcen.scm create mode 100644 acconfig-1.5.h create mode 100644 bench.scm create mode 100755 build.bat create mode 100755 build.scm create mode 100755 configure create mode 100644 configure.in create mode 100644 continue.c create mode 100644 continue.h create mode 100644 crs.c create mode 100644 dynl.c create mode 100644 ecrt0.c create mode 100644 edline.c create mode 100644 eval.c create mode 100644 example.scm create mode 100644 findexec.c create mode 100644 gmalloc.c create mode 100644 gsubr.c create mode 100644 install-sh create mode 100644 ioext.c create mode 100755 mkinstalldirs create mode 100644 patchlvl.h create mode 100644 pi.c create mode 100644 pi.scm create mode 100644 posix.c create mode 100644 pre-crt0.c create mode 100644 r4rstest.scm create mode 100644 ramap.c create mode 100644 record.c create mode 100644 repl.c create mode 100644 rgx.c create mode 100644 rope.c create mode 100644 sc2.c create mode 100644 scl.c create mode 100644 scm.1 create mode 100644 scm.c create mode 100644 scm.doc create mode 100644 scm.h create mode 100644 scm.texi create mode 100644 scm4e3.scmconfig.patch create mode 100644 scmconfig.h.in create mode 100644 scmfig.h create mode 100644 setjump.h create mode 100644 setjump.mar create mode 100644 setjump.s create mode 100644 socket.c create mode 100644 split.scm create mode 100644 subr.c create mode 100644 sys.c create mode 100644 time.c create mode 100644 unexec.c create mode 100644 unexelf.c create mode 100644 unif.c create mode 100644 unix.c 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 : + + * 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 + + * 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 + + * 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. diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..a43ea21 --- /dev/null +++ b/COPYING @@ -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. + + + Copyright (C) 19yy + + This program is free software; you can redistribute 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. + + , 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * Init.scm (exec-self): Added. + + * repl.c (init_repl): DUMP sets RESTART to EXEC-SELF. + +Mon Oct 28 11:39:30 1996 Aubrey Jaffer + + * 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 + + * 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 + + * 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 + + * 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 + + * eval.c (unmemocar): The code in unmemocar to deal with ILOCs was + never being executed. + +Fri Oct 4 13:57:35 1996 Aubrey Jaffer + + * sys.c (igc): symhash GC can now be disabled with + #define NO_SYM_GC. + +Wed Oct 2 20:51:07 1996 Aubrey Jaffer + + * 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 + + * scm.texi (File-System Habitat): improved wording and added + examples. + +Thu Sep 26 22:23:32 1996 Radey Shouman + + * sys.c (intern): fixed (new) symhash GC bug. + +Tue Sep 24 13:55:11 1996 Aubrey Jaffer + + * 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 + + * repl.c (gc_ports_collected): added to instrument symbol GC. + +Sat Sep 14 15:35:29 1996 Radey Shouman + + * 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 + + * scm.texi (Debugging Scheme Code): Added section. + +Sat Aug 31 14:05:24 1996 Eric Hanchrow + + * 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 + + * eval.c (definedp): Changed from a memoizing macro to a `syntax'. + +Sun Jul 21 01:06:44 1996 Aubrey Jaffer + + * Link.scm (link-named-scm): fixed to call "build.scm". + +Sat Jul 20 23:53:17 1996 Aubrey Jaffer + + * scm.texi (Memoized Expressions): section added. + (Errors): section added. + +Wed Jul 17 17:40:01 1996 Aubrey Jaffer + + * r4rstest.scm: renamed from "test.scm". Now carries copyright + notice suitable for single file distribution. + +Fri May 17 23:37:16 1996 Aubrey Jaffer + + * findexec.c (dld_find_executable): names changed to keep up with + DLD changes. + +Sun May 12 21:43:14 1996 Radey Shouman + + * 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! '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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * ramap.c: removed #ifdef ARRAYS (over whole file). + +Wed Apr 3 10:14:18 1996 Aubrey Jaffer + + * 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 + + * sys.c (stack_check): sizeof(STACKITEM) was multiplied on wrong + side of inequality. + +Fri Mar 29 23:52:03 1996 Aubrey Jaffer + + * 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 + + * build.scm (build): fixed -tdll to not make archive or compile + all 'linkable files. + +Sun Mar 10 17:23:39 1996 Radey Shouman + + * 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! 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 + + * 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 + + * README (Making SCM with Think C 4.0 or 4.1): Instructions added + back in. + +Sun Mar 17 00:17:21 1996 Aubrey Jaffer + + * findexec.c (dld_find_executable): Added support for ~ and ~/ in + PATH environment variable. + +Sat Mar 16 10:38:15 1996 Aubrey Jaffer + + * 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 + + * 4e3: released. + * repl.c (read_token): ',' now delimits token. + +Mon Mar 4 23:19:50 1996 Aubrey Jaffer + + * 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 + + * build.bat: Added for MS-DOS. + +Fri Mar 1 23:47:57 1996 Aubrey Jaffer + + * 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 + + * 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 + + * 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 + + * findexec.c (dld_find_executable): extracted from DLD for + general use. + +Tue Feb 20 00:08:29 1996 Jochen Schwarze + + * 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 + + * subr.c (divbigint): fixed sign bug for 0 return value. + +Sun Feb 18 00:29:43 1996 Per Bothner + + * gsubr.c (gsubr_apply): elided gratuitous make_vector call. + +Sat Feb 17 11:50:41 1996 Aubrey Jaffer + + * 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 + * 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 + * 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 + * 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 + * 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 + * 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 '()) 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 and #include . define ttyname() + macro. + + * scm.c: #include and compile out execvp() call. + + * time.c: #include + + * 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 * + 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 + * 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 + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + #\. + + * 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 #. + +Tue Feb 15 01:08:10 1994 Shiro KAWAI + + * 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" + + * 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 + 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 + + * 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 . + +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 + + * 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 +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 + + * 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 + * 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 + * 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" + * 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 + * 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 + * 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 + * 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 # 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 + * 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 + + * 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 _INIT_PATH when + 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 + * 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" + * 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" + + * 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 instead of + + * repl.c: SVR2 needs LACK_FTIME + + * repl.c: #include 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. : + + * repl.c sys.c (errno): VMS GNU C uses a special hack in + 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 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 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 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 evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (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 ) 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 ) 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: + any Scheme data object. + * zero or more objects + + one or more objects + [] optional object + ( )... Zero or more occurances of ( ) + +; SYNTAX + + (LAMBDA + ) + (LAMBDA (* ) + ) + (AND *) + (OR *) + (IF [] ) + (COND ( * )... [(ELSE +)] ) + (CASE ((+ ) * )... [(ELSE +)] ) + (DEFINE ( * ) + ) + (DEFINE ) + (LET [] ( ( )... ) + ) + (LET* ( ( )... ) + ) + (LETREC ( ( )... ) + ) + (BEGIN + ) + (DO ( ( )... ) ( * ) * ) + ;; Note also R^4RS syntax, below + + +; IEEE Scheme + + (NOT ) + (BOOLEAN? ) + + (EQ? ) + (EQV? ) + (EQUAL? ) + + (PAIR? ) + (CONS ) + (CAR ) + (CDR ) + (SET-CAR! ) + (SET-CDR! ) + (CAAR ) (CADR ) (CDAR ) (CDDR ) + (CAAAR ) (CAADR ) (CADAR ) (CADDR ) + (CDAAR ) (CDADR ) (CDDAR ) (CDDDR ) + (CAAAAR ) (CAAADR ) (CAADAR ) (CAADDR ) + (CADAAR ) (CADADR ) (CADDAR ) (CADDDR ) + (CDAAAR ) (CDAADR ) (CDADAR ) (CDADDR ) + (CDDAAR ) (CDDADR ) (CDDDAR ) (CDDDDR ) + (NULL? ) + (LIST? ) + (LIST * ) + (LENGTH ) + (APPEND + ) + (REVERSE ) + (LIST-REF ) + + (MEMQ ) + (MEMV ) + (MEMBER ) + + (ASSQ ) + (ASSV ) + (ASSOC ) + + (SYMBOL? ) (SYMBOL->STRING ) (STRING->SYMBOL ) + + (NUMBER? ) + (COMPLEX? ) + (REAL? ) + (RATIONAL? ) + (INTEGER? ) + (EXACT? ) (INEXACT? ) + (= + ) + (< + ) (> + ) + (<= + ) (>= + ) + (ZERO? ) + (POSITIVE? ) (NEGATIVE? ) + (ODD? ) (EVEN? ) + (MAX + ) (MIN + ) + (+ + ) + (* + ) + (- + ) + (/ + ) + (ABS ) + (QUOTIENT ) (REMAINDER ) + (MODULO ) + (GCD * ) (LCM * ) + (NUMERATOR ) (DENOMINATOR ) + (FLOOR ) (CEILING ) + (TRUNCATE ) (ROUND ) + (RATIONALIZE ) + (EXP ) (LOG ) + (SIN ) (COS ) (TAN ) + (ASIN ) (ACOS ) (ATAN []) + (SQRT ) + (EXPT ) + (MAKE-RECTANGULAR ) (MAKE-POLAR ) + (REAL-PART ) (IMAG-PART ) + (MAGNITUDE ) (ANGLE ) + (EXACT->INEXACT ) (INEXACT->EXACT ) + (NUMBER->STRING ) (STRING->NUMBER ) + + (CHAR? ) + (CHAR=? ) (CHAR-CI=? ) + (CHAR ) (CHAR-CI ) + (CHAR>? ) (CHAR-CI>? ) + (CHAR<=? ) (CHAR-CI<=? ) + (CHAR>=? ) (CHAR-CI>=? ) + (CHAR-ALPHABETIC? ) + (CHAR-NUMERIC? ) + (CHAR-WHITESPACE? ) + (CHAR-UPPER-CASE? ) (CHAR-LOWER-CASE? ) + (CHAR->INTEGER ) (INTEGER->CHAR ) + (CHAR-UPCASE ) (CHAR-DOWNCASE ) + + (STRING? ) + (MAKE-STRING [] ) + (STRING + ) + (STRING-LENGTH ) + (STRING-REF ) + (STRING-SET! ) + (STRING=? ) (STRING-CI=? ) + (STRING ) (STRING-CI ) + (STRING>? ) (STRING-CI>? ) + (STRING<=? ) (STRING-CI<=? ) + (STRING>=? ) (STRING-CI>=? ) + (SUBSTRING ) + (STRING-APPEND + ) + + (VECTOR? ) + (MAKE-VECTOR [] ) + (VECTOR * ) + (VECTOR-LENGTH ) + (VECTOR-REF ) + (VECTOR-SET! ) + + (PROCEDURE? ) + (APPLY * ) + (MAP + ) + (FOR-EACH + ) + (CALL-WITH-CURRENT-CONTINUATION ) + + (CALL-WITH-INPUT-FILE ) + (CALL-WITH-OUTPUT-FILE ) + (INPUT-PORT? ) (OUTPUT-PORT? ) + (CURRENT-INPUT-PORT) (CURRENT-OUTPUT-PORT) + (OPEN-INPUT-FILE ) (OPEN-OUTPUT-FILE ) + (CLOSE-INPUT-PORT ) (CLOSE-OUTPUT-PORT ) + (EOF-OBJECT? ) + (READ [] ) + (READ-CHAR [] ) + (PEEK-CHAR [] ) + (WRITE [] ) + (DISPLAY [] ) + (NEWLINE [] ) + (WRITE-CHAR [] ) + + +; R4RS Scheme + + (LIST-TAIL ) + (STRING->LIST ) + (LIST->STRING ) + (STRING-COPY ) + (STRING-FILL! ) + (VECTOR->LIST ) + (LIST->VECTOR ) + (VECTOR-FILL! ) + (DELAY ) + (FORCE ) + (WITH-INPUT-FROM-FILE ) + (WITH-OUTPUT-TO-FILE ) + (CHAR-READY? [] ) + (LOAD ) + (TRANSCRIPT-ON ) + (TRANSCRIPT-OFF) + + (DEFINE-SYNTAX ) -- High-Level macros (only) + (LET-SYNTAX ( * ) + ) + (LETREC-SYNTAX ( * ) + ) + + + +=== 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). diff --git a/README b/README new file mode 100644 index 0000000..7dbcf52 --- /dev/null +++ b/README @@ -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 + + 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 . 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 and + . remove + STDC_HEADERS in scmfig.h + + edit 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 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 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 , +and is maintained by me. Please direct any problems you have with +either scm itself or this configuration software to . + +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 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 + 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 +, 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 and 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 \") 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 < 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 < +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 < 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 +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 < +#include +#include +#include +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 ' > 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 < +#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 +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 < +#include +#include +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 < +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 < +#include +#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 <> 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 < config.status </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 < 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 <> 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 +# 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 +# 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 diff --git a/crs.c b/crs.c new file mode 100644 index 0000000..5a4a5f1 --- /dev/null +++ b/crs.c @@ -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 + +#ifdef MWC +# include +#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); +} diff --git a/dynl.c b/dynl.c new file mode 100644 index 0000000..6cd3b58 --- /dev/null +++ b/dynl.c @@ -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("#', 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 +# include +# include + +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 + +# 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("#', 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 */ diff --git a/ecrt0.c b/ecrt0.c new file mode 100644 index 0000000..a9c7f28 --- /dev/null +++ b/ecrt0.c @@ -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 +#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 + +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 /* 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); +} diff --git a/eval.c b/eval.c new file mode 100644 index 0000000..2cf04fe --- /dev/null +++ b/eval.c @@ -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 (( ) + ( ) + ... ) + ( ) + ) + ;; becomes + (do_mem (varn ... var2 var1) + ( ... ) + ( ) + () + ... ) ;; 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 */ + 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("#', 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("#', 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 + + * 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 +#include +#ifdef linux +# include +# include +# include /* for X_OK define */ +#endif +#ifdef __svr4__ +# include +# include +# include +# include /* for X_OK define */ +#else +# ifdef __sgi__ +# include +# include +# include +# include /* for X_OK define */ +# else +# include +# 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 +#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 +#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 +#else +#ifndef CHAR_BIT +#define CHAR_BIT 8 +#endif +#endif + +#ifdef HAVE_UNISTD_H +#include +#endif + +#endif /* _MALLOC_INTERNAL. */ + + +#ifdef __cplusplus +extern "C" +{ +#endif + +#if defined (__STDC__) && __STDC__ +#include +#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 +#endif +#include + +/* 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 +#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 +#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 +#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 +#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 +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 +#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 +#include +extern size_t __getpagesize __P ((void)); +#else +#include "getpagesize.h" +#define __getpagesize() getpagesize() +#endif + +#ifndef _MALLOC_INTERNAL +#define _MALLOC_INTERNAL +#include +#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. */ diff --git a/gsubr.c b/gsubr.c new file mode 100644 index 0000000..96b0f78 --- /dev/null +++ b/gsubr.c @@ -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 diff --git a/ioext.c b/ioext.c new file mode 100644 index 0000000..3e77a29 --- /dev/null +++ b/ioext.c @@ -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 +#endif + +#ifndef THINK_C +# ifdef vms +# include +# else +# include +# endif +# ifdef __TURBOC__ +# include +# endif +SCM stat2scm P((struct stat *stat_temp)); +/* int mkdir P((const char *path, mode_t mode)); */ +#endif +#ifdef hpux +# include +#endif +#ifdef __sgi__ +# include +#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 +# include +# include +# endif +# ifdef __HIGHC__ +# include +# include +# include +# 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 +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 +# 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 +# else +# ifdef _WIN32 +# include +# else +# include +# 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 +# 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 +# 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 +# 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 diff --git a/pi.c b/pi.c new file mode 100644 index 0000000..2047d2b --- /dev/null +++ b/pi.c @@ -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 prints out digits of pi in groups of digits. + +'Spigot' algorithm origionally due to Stanly Rabinowitz. +This algorithm takes time proportional to the square of /. +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 will have to be reduced for larger 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++ ) prints out digits of pi in groups of digits. + +;;; 'Spigot' algorithm origionally due to Stanly Rabinowitz. +;;; This algorithm takes time proportional to the square of /. +;;; 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 will have to be reduced for larger 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 ) prints out 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 ) prints out 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)))) diff --git a/posix.c b/posix.c new file mode 100644 index 0000000..422d61d --- /dev/null +++ b/posix.c @@ -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 +#include +#include + +#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 +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 +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 #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 #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 #t string<=? "" "") +(test #t string>=? "" "") +(test #t 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 #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 #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" diff --git a/ramap.c b/ramap.c new file mode 100644 index 0000000..b869ff6 --- /dev/null +++ b/ramap.c @@ -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< 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("#', 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); +} diff --git a/repl.c b/repl.c new file mode 100644 index 0000000..48ac94a --- /dev/null +++ b/repl.c @@ -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 +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", "#", "()", "#" + }; + +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("#', 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("#', port, writing); + break; + case tc7_string: + if (writing) { + lputc('\"', port); + for(i = 0;i', port); + break; +#ifdef CCLO + case tc7_cclo: + lputs("#', port); + break; +#endif + case tc7_contin: + lputs("#', port); + break; + case tc7_port: + i = PTOBNUM(exp); + if (i +# include +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 +# else +# ifndef AMIGA +# ifndef vms +# ifdef MWC +# include +# else +# ifndef THINK_C +# ifndef ARM_ULIB +# include +# endif +# endif +# endif +# endif +# endif +# endif + +# ifdef HAVE_SELECT +# ifdef HAVE_SYS_TIME_H +# include +# 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= 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("#', 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(i2) { + 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; +} diff --git a/rgx.c b/rgx.c new file mode 100644 index 0000000..e766083 --- /dev/null +++ b/rgx.c @@ -0,0 +1,661 @@ +#include "scm.h" +#include "regex.h" +#include + +static char rcsid[] = + "$Id: rgx.c, v 1.20 1995/02/15 04:39:45 dpb Exp $"; + +#ifdef HAVE_ALLOCA +# include +# 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("#', 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; ifastmap = 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; ioptions = 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 []) */ +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='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); +} diff --git a/rope.c b/rope.c new file mode 100644 index 0000000..c922046 --- /dev/null +++ b/rope.c @@ -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 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() +{ +} diff --git a/sc2.c b/sc2.c new file mode 100644 index 0000000..904458a --- /dev/null +++ b/sc2.c @@ -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= 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= 0, start, OUTOFRANGE, s_subfl); + ASSERT(e <= LENGTH(str) && e >= 0, end, OUTOFRANGE, s_subfl); + while(i + +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 +} diff --git a/scm.1 b/scm.1 new file mode 100644 index 0000000..d536061 --- /dev/null +++ b/scm.1 @@ -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. + diff --git a/scm.c b/scm.c new file mode 100644 index 0000000..ce8e834 --- /dev/null +++ b/scm.c @@ -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 +#include "scm.h" +#include "patchlvl.h" + +#ifdef __IBMC__ +# include +#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 */ + +#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 +#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 +# include +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)); +} diff --git a/scm.doc b/scm.doc new file mode 100644 index 0000000..eaa34e0 --- /dev/null +++ b/scm.doc @@ -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 + + diff --git a/scm.h b/scm.h new file mode 100644 index 0000000..1f01292 --- /dev/null +++ b/scm.h @@ -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 +#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 + +@end ifset + +@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html + +@ifset html + +@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 + +@end ifset +@cite{Simply Scheme: Introducing Computer Science} +@ifset html + +@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 + +@end ifset +Revised(4) Report on the Algorithmic Language Scheme. +@ifset html + +@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 + +@end ifset +The Guile Architecture for Ubiquitous Computing. +@ifset html + +@end ifset +@cite{Usenix Symposium on Tcl/Tk}, 1995. + +@item [SLIB] +@pindex SLIB +Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. +@ifset html + +@end ifset +SLIB, The Portable Scheme Library. +@ifset html + +@end ifset +Version 2a3, June 1995. +@ifinfo + +@ref{Top, , , slib, SLIB}. +@end ifinfo + +@item [JACAL] +@pindex JACAL +Aubrey Jaffer. +@ifset html + +@end ifset +JACAL Symbolic Mathematics System. +@ifset html + +@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 + +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el + + +ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el + +@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 '} 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 + +@end ifset +SLIB-PSD, the Portable Scheme Debugger +@ifset html + +@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 + +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 + +@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 + +prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz + +@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 and . remove +STDC_HEADERS in @file{scmfig.h}. + +edit 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 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) + # + # + # + # +@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 +# +> (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 +# +@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], +@end ifset +@cite{Revised(4) Report on the Algorithmic Language Scheme}. +@ifset html + +@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 )} +@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{}@r{-}@i{}, where @i{} is the number of binding +contours back and @i{} 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{} +# +@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{} # +open-input-file @result{} +# +@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{} +# +@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{} # +@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{} # +'(#.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{#} in which case the expression will be treated as +whitespace. @code{#} 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}, +where 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") +# +> (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{} + # + +(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} + # +@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 +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 + +@end ifset +@code{ftp.sys.toronto.edu:/pub/rc/editline.shar} +@ifset html + +@end ifset +@item +@ifset html + +@end ifset +@code{prep.ai.mit.edu:/pub/gnu/readline-2.0.tar.gz} +@ifset html + +@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{#}. +@end deftypevr +@deftypevr {Immediate Constant} SCM UNDEFINED +@code{#} used for variables which have not been defined and +absent optional arguments. +@end deftypevr +@deftypevr {Immediate Constant} SCM UNSPECIFIED +@code{#} 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{#}, @code{#}, @code{()}, and +@code{#}. + +@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{}} 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 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 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 + #include +! #include +! #ifdef linux + # include + # include + # include /* 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 + #include +! #if defined(linux) || defined(__svr4__) + # include + # include + # include /* 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 + # 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 and . */ +#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 header file. */ +#undef HAVE_LIMITS_H + +/* Define if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define if you have the header file. */ +#undef HAVE_STRING_H + +/* Define if you have the header file. */ +#undef HAVE_SYS_TIME_H + +/* Define if you have the header file. */ +#undef HAVE_SYS_TIMEB_H + +/* Define if you have the header file. */ +#undef HAVE_SYS_TIMES_H + +/* Define if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define if you have the header file. */ +#undef HAVE_TIME_H + +/* Define if you have the 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 +# else +# include +# endif + +# ifndef HAVE_GETCWD +# define getcwd(S,L) getwd(S) +# endif + +#else /* HAVE_CONFIG_H */ + +# ifdef sequent +# include +# define strchr index +# define strrchr rindex +# else +# include +# 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 +# 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 +# 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 +# ifdef AMIGA +# include +# 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 + +/* SYSCALL retries system calls that have been interrupted (EINTR) */ +#ifdef vms +# ifndef __GNUC__ +# include +# 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 ). */ + +#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 + 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 + 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 +* + 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 +#include +#include +#include +#include +#include + +#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*)))) diff --git a/subr.c b/subr.c new file mode 100644 index 0000000..4b75e13 --- /dev/null +++ b/subr.c @@ -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 +#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_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= 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 != 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;i0) 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;i0) 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= 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); +} diff --git a/sys.c b/sys.c new file mode 100644 index 0000000..0a9615b --- /dev/null +++ b/sys.c @@ -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 + +#include "scm.h" +#include "setjump.h" +void igc P((char *what, STACKITEM *stackbase)); + +/* ttyname() etc. should be defined in . 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 +# include +# define ttyname(x) "CON:" +#else +# ifndef MSDOS +# ifndef ultrix +# ifndef vms +# ifdef _DCC +# include +# define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0) +# else +# ifdef MWC +# include +# else +# ifndef THINK_C +# ifndef ARM_ULIB +# include +# 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 + 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(i5) + { + 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>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 */ + } +} diff --git a/time.c b/time.c new file mode 100644 index 0000000..871082f --- /dev/null +++ b/time.c @@ -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 +# endif +# ifdef TIME_WITH_SYS_TIME +# include +# include +# else +# ifdef HAVE_SYS_TIME_H +# include +# else +# ifdef HAVE_TIME_H +# include +# endif +# endif +# endif +# ifdef HAVE_SYS_TIMES_H +# include +# else +# ifdef HAVE_SYS_TIMEB_H +# include +# endif +# endif +# ifdef HAVE_FTIME +# ifdef unix +# ifndef GO32 +# include +# endif +# endif +# endif + +#else + +# ifdef STDC_HEADERS +# include +# ifdef M_SYSV +# include +# include +# endif +# ifdef sun +# include +# include +# endif +# ifdef ultrix +# include +# include +# endif +# ifdef nosve +# include +# include +# endif +# ifdef _UNICOS +# include +# include +# endif +# ifdef __IBMC__ +# include +# endif +# else +# ifdef SVR2 +# include +# else +# ifndef ARM_ULIB +# include +# else +# include +# endif +# endif +# include + +# ifndef ARM_ULIB +# include +# else +# include +# 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 +# include +# endif +# endif +# ifdef _UNICOS +# define LACK_FTIME +# endif + +# ifndef LACK_FTIME +# ifdef unix +# ifndef GO32 +# include +# endif +# endif +# endif + +# ifdef __EMX__ +# define LACK_TIMES +# include +# include +# endif + +# ifdef MWC +# include +# include +# endif + +# ifdef ARM_ULIB +# include +# include +# 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 +# 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 +# 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" */ +# ifdef AZTEC_C /* AZTEC_C */ +# include +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 +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef COFF_ENCAPSULATE +int need_coff_header = 1; +#include /* The location might be a poor assumption */ +#else +#ifdef MSDOS +#if __DJGPP__ > 1 +#include /* for O_RDONLY, O_RDWR */ +#include /* for _crt0_startup_flags and its bits */ +static int save_djgpp_startup_flags; +#endif +#include +#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 +#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 +#endif /* makedev */ +#include +#include +#include + +#include /* Must be after sys/types.h for USG and BSD4_1*/ + +#ifdef USG5 +#include +#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 +#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 +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifndef emacs +#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1) +#else +#include +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); +} diff --git a/unif.c b/unif.c new file mode 100644 index 0000000..4bc2ecf --- /dev/null +++ b/unif.c @@ -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, (k0) ? 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)) && jlbnd) || 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 +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("', 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 */ diff --git a/unix.c b/unix.c new file mode 100644 index 0000000..4437189 --- /dev/null +++ b/unix.c @@ -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 +#include +/* #include */ +#include + +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"); +} -- cgit v1.2.3