summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:23 -0800
commit5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (patch)
tree9b744b9dbf39e716e56daa620e2f3041968caf19
downloadscm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.tar.gz
scm-5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8.zip
Import Upstream version 4e6upstream/4e6
-rw-r--r--ANNOUNCE218
-rw-r--r--COPYING339
-rw-r--r--ChangeLog3029
-rw-r--r--Iedline.scm103
-rw-r--r--Init.scm854
-rw-r--r--Link.scm284
-rw-r--r--Makefile384
-rw-r--r--Makefile.in462
-rw-r--r--QUICKREF201
-rw-r--r--README384
-rw-r--r--README.unix182
-rw-r--r--Transcen.scm133
-rw-r--r--acconfig-1.5.h22
-rw-r--r--bench.scm55
-rwxr-xr-xbuild.bat1
-rwxr-xr-xbuild.scm1393
-rwxr-xr-xconfigure849
-rw-r--r--configure.in33
-rw-r--r--continue.c255
-rw-r--r--continue.h178
-rw-r--r--crs.c412
-rw-r--r--dynl.c448
-rw-r--r--ecrt0.c614
-rw-r--r--edline.c94
-rw-r--r--eval.c1494
-rw-r--r--example.scm137
-rw-r--r--findexec.c145
-rw-r--r--gmalloc.c1638
-rw-r--r--gsubr.c138
-rw-r--r--install-sh238
-rw-r--r--ioext.c703
-rwxr-xr-xmkinstalldirs35
-rw-r--r--patchlvl.h8
-rw-r--r--pi.c78
-rw-r--r--pi.scm165
-rw-r--r--posix.c408
-rw-r--r--pre-crt0.c9
-rw-r--r--r4rstest.scm1038
-rw-r--r--ramap.c1677
-rw-r--r--record.c349
-rw-r--r--repl.c1649
-rw-r--r--rgx.c661
-rw-r--r--rope.c335
-rw-r--r--sc2.c172
-rw-r--r--scl.c2393
-rw-r--r--scm.1335
-rw-r--r--scm.c940
-rw-r--r--scm.doc330
-rw-r--r--scm.h817
-rw-r--r--scm.texi6911
-rw-r--r--scm4e3.scmconfig.patch60
-rw-r--r--scmconfig.h.in69
-rw-r--r--scmfig.h671
-rw-r--r--setjump.h122
-rw-r--r--setjump.mar38
-rw-r--r--setjump.s40
-rw-r--r--socket.c635
-rw-r--r--split.scm87
-rw-r--r--subr.c2009
-rw-r--r--sys.c1758
-rw-r--r--time.c389
-rw-r--r--unexec.c1238
-rw-r--r--unexelf.c908
-rw-r--r--unif.c2000
-rw-r--r--unix.c151
65 files changed, 43905 insertions, 0 deletions
diff --git a/ANNOUNCE b/ANNOUNCE
new file mode 100644
index 0000000..0edea3c
--- /dev/null
+++ b/ANNOUNCE
@@ -0,0 +1,218 @@
+This message announces the availability of Scheme release scm4e6.
+
+New in scm4e6 are:
+
+ * bench.scm (benchmark): added. computes and display statistics
+ on "pi.scm" benchmark.
+ * Makefile (benchlit bench): targets added. Append stats to file
+ "BenchLog".
+ * scm.texi (Socket): added examples of chat servers and clients.
+ (Internet Addresses and Socket Names): enlarged from "Internet
+ Addresses".
+ * socket.c (l_connect): BUF0 was missing from mode bits set in
+ returned port.
+ * build.scm (build-params): Added compiler-options and
+ linker-options; added --batch-dialect and --script-name as aliases
+ for -h and -w.
+ * scmfig.h (HAVE_SELECT): Now defined for linux.
+ * sys.c (igc): fixed off-by-1 error for sizeof save_regs_gc_mark.
+ (gc_mark): fixed off-by-1 error for sizeof(CONTINUATION). These
+ seem to fix a very obscure GC bug.
+ * Init.scm (exec-self): Added.
+ * repl.c (init_repl): DUMP sets RESTART to EXEC-SELF.
+ * repl.c (tryload): Made tail-recursive so that dump, quit, exit,
+ etc. will work as the last expression in a loading file.
+ (scm_execpath): Split out from scm_unexec.
+ * unexec.c: All Updated from emacs-19.34 -- no changes necessary.
+ * gmalloc.c:
+ * pre-crt0.c:
+ * ecrt0.c:
+ * unexelf.c: fixes Linux (ELF) dump bug.
+ * build.scm (platform): linux renamed linux-aout. linux-elf fixed
+ and renamed linux.
+ (C-libraries): X11R6 moved library files on RedHat Linux. Linux
+ graphics library now has entry (doesn't default).
+ (compile-dll-c-files linux):
+ (make-dll-archive linux): Now converts from ".o" objects to ELF
+ ".so" form and "links" the usual libraries.
+ * Link.scm (usr:lib x:lib): dynamic linking fixed for (linux ELF)
+ dlopen. Libraries other than ".so" object not needed; eliminated
+ by usr:lib and x:lib returning #f.
+ * dynl.c (l_dyn_unlink): prints result of dlerror() on errors.
+ * eval.c (nconc2last): If CAUTIOUS is defined, checks that
+ APPLY's arglist and last element of arglist are LIST?s.
+ * sys.c (igc): symhash GC can now be disabled with
+ #define NO_SYM_GC.
+ * Init.scm (boot-tail): Added FSF --help and --version options.
+ Added --no-init-file as a synonym for -no-init-file.
+ * scm.texi (File-System Habitat): improved wording and added
+ examples.
+ * scm.texi (Top): Renamed sections.
+ * sys.c (mark_syms mark_sym_values): Split up mark_symhash() to
+ immunize against accidental pointers.
+ * repl.c (gc_ports_collected): added to instrument symbol GC.
+ * scm.texi (Debugging Scheme Code): Added section.
+ * eval.c (definedp): Changed from a memoizing macro to a `syntax'.
+
+ From maximum entropy <entropy@zippy.bernstein.com>:
+
+ * ioext.c, scmfig.h: support for SGI (tested with SGI IRIX 5.2/gcc)
+ * ioext.c (file_set_position): If a port is bidirectional
+ (e.g. a socket) it may be necessary on some systems to perform a
+ file positioning operation when switching between reading and
+ writing. This is required by ANSI C (ISO/IEC 9899:1990
+ 7.9.5.3). Therefore, a file-set-position on a bidirectional
+ port should not signal an error if fseek generates an
+ ESPIPE -- the fseek operation actually "succeeded" in that it
+ reset the I/O direction flag for the FILE.
+ * repl.c (input_waiting): R4RS requires that "char-ready?"
+ return "#t" at end-of-file. The semantics for "ioctl(...,
+ FIONREAD, ...)" are such that it gives 0 on a socket that is
+ closed (on the other side of the connection). If the
+ system has select(), use that instead to get the correct
+ behavior.
+ * socket.c (l_listen): Treat sockets that have been "listened"
+ as input-ports. This allows polling for new connections
+ (e.g. with "char-ready?") instead of blocking in
+ "socket:accept".
+ * socket.c (l_accept): Fix type checking to agree with
+ previous patch.
+
+ From Radey Shouman <shouman@zianet.com>
+
+ * eval.c (unmemocar): The code in unmemocar to deal with ILOCs was
+ never being executed.
+ * sys.c (intern): fixed (new) symhash GC bug.
+ * sys.c (igc): Added calls to mark_symhash() and sweep_symhash().
+ These GC unused symbols with a top-level value of UNDEFINED.
+ (mark_symhash): added.
+ (sweep_symhash): added.
+
+ From Eric Hanchrow <erich@MICROSOFT.com>
+
+ * scm.c (l_sleep): Ported to Windows NT (_WIN32)
+ * ioext.c: Ported to Windows NT (_WIN32)
+
+ -=-=-
+
+Scm conforms to Revised^4 Report on the Algorithmic Language Scheme
+and the IEEE P1178 specification. Scm is written in C and runs under
+Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS, Unix and
+similar systems. ASCII and EBCDIC are supported.
+
+Documentation is included explaining the many Scheme Language
+extensions in scm, the internal representations, and how to extend or
+include SCM in other programs. Documentation is online at:
+
+ http://ftp-swiss.ai.mit.edu/~jaffer/SCM.html
+
+SCM can be obtained via FTP (detailed instructions follow) from:
+ ftp-swiss.ai.mit.edu:pub/scm/scm4e6.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/scm4e6.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/scm4e6.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/scm4e6.tar.gz
+
+SLIB is a portable Scheme library which SCM uses:
+ ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2a6.tar.gz
+
+JACAL is a symbolic math system written in Scheme:
+ ftp-swiss.ai.mit.edu:pub/scm/jacal1a5.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/jacal1a5.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/jacal1a5.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/code/num/jacal1a5.tar.gz
+
+HOBBIT is a compiler for SCM code:
+ ftp-swiss.ai.mit.edu:pub/scm/hobbit4d.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/hobbit4d.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/hobbit4d.tar.gz
+
+SCMCONFIG contains additional files for the SCM distribution to build
+SCM on Unix machines using GNU autoconf.
+ ftp-swiss.ai.mit.edu:pub/scm/scmconfig4e3.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/scmconfig4e3.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/scmconfig4e3.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/scmconfig4e3.tar.gz
+
+SLIB-PSD is a portable debugger for Scheme (requires emacs editor):
+ ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz
+
+SLIB-SCHELOG is an embedding of Prolog in Scheme:
+ ftp-swiss.ai.mit.edu:pub/scm/slib-schelog.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/slib-schelog.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-schelog.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-schelog.tar.gz
+
+SMG-SCM is an SMG interface package which works with SCM on VMS.
+ ftp-swiss.ai.mit.edu:pub/scm/smg-scm2a1.zip
+ prep.ai.mit.edu:pub/gnu/jacal/smg-scm2a1.zip
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/smg-scm2a1.zip
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/smg-scm2a1.zip
+A VMS version of Unzip is available by anonymous FTP from
+ ftp.spc.edu:[ANONYMOUS.MACRO32]UNZIP.EXE.
+
+TURTLSCM is a turtle graphics package which works with SCM on MS-DOS
+or X11 machines:
+ ftp-swiss.ai.mit.edu:pub/scm/turtlegr.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/turtlegr.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/turtlegr.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/turtlegr.tar.gz
+
+XSCM is a X windows interface package which works with SCM:
+ ftp-swiss.ai.mit.edu:pub/scm/xscm-2.01.tar.gz
+ prep.ai.mit.edu:pub/gnu/jacal/xscm-2.01.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/xscm-2.01.tar.gz
+
+MacSCM is a Macintosh applications building package which works with
+SCM (similar to XSCM).
+ ftp-swiss.ai.mit.edu:pub/scm/macscm.tar.Z
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/macscm.tar.Z
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/macscm.tar.gz
+
+WB is a disk based, sorted associative array (B-tree) library for SCM.
+Using WB, large databases can be created and managed from SCM.
+ ftp-swiss.ai.mit.edu:pub/scm/wb1a2.tar.gz
+ ftp.maths.tcd.ie:pub/bosullvn/jacal/wb1a2.tar.gz
+ ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/wb1a2.tar.gz
+
+DLD is a C library package allowing SCM to dynamically load object
+files on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation
+(SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST.
+
+ prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz
+ -=-=-
+
+ ftp ftp-swiss.ai.mit.edu (anonymous)
+ bin
+ cd pub/scm
+ get scm4e6.tar.gz
+ get slib2a6.tar.gz
+or
+ ftp prep.ai.mit.edu (anonymous)
+ bin
+ cd pub/gnu/jacal
+ get scm4e6.tar.gz
+ get slib2a6.tar.gz
+
+ `scm4e6.tar.gz' is a gzipped tar file of the C code distribution.
+ `slib2a6.tar.gz' is a gzipped tar file of a Scheme Library.
+
+Files in these directories with the ".gz" suffix are compressed with
+patent-free gzip (no relation to zip). The program to uncompress them
+is available from
+ prep.ai.mit.edu:pub/gnu/gzip-1.2.4.tar
+ prep.ai.mit.edu:pub/gnu/gzip-1.2.4.shar
+ prep.ai.mit.edu:pub/gnu/gzip-1.2.4.msdos.exe
+
+Remember to use binary mode when transferring the files.
+Be sure to get and read the GNU General Public License (COPYING).
+It is included in scm4e6.tar.gz.
+
+I sell IBM PC floppy disk sets with the source files, documentation,
+and MS-DOS and i386 MS-DOS executables for $99.00. To order, send
+e-mail to jaffer@ai.mit.edu.
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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19yy name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..e689bb5
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,3029 @@
+Mon Nov 18 22:56:11 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * patchlvl.h (SCMVERSION): 4e6 released.
+
+ * bench.scm (benchmark): added. computes and display statistics
+ on "pi.scm" benchmark.
+
+ * Makefile (benchlit bench): targets added. Append stats to file
+ "BenchLog".
+
+Sun Nov 17 22:21:28 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * scm.texi (Socket): added examples of chat servers and clients.
+ (Internet Addresses and Socket Names): enlarged from "Internet
+ Addresses".
+
+ * socket.c (l_connect): BUF0 was missing from mode bits set in
+ returned port.
+
+Sat Nov 16 22:02:39 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * build.scm (build-params): Added compiler-options and
+ linker-options; added --batch-dialect and --script-name as aliases
+ for -h and -w.
+
+ * scmfig.h (HAVE_SELECT): Now defined for linux.
+
+Sat Nov 2 09:24:50 EST 1996 maximum entropy <entropy@zippy.bernstein.com>
+
+ * ioext.c, scmfig.h: support for SGI (tested with SGI IRIX 5.2/gcc)
+
+ * ioext.c (file_set_position): If a port is bidirectional
+ (e.g. a socket) it may be necessary on some systems to perform a
+ file positioning operation when switching between reading and
+ writing. This is required by ANSI C (ISO/IEC 9899:1990
+ 7.9.5.3). Therefore, a file-set-position on a bidirectional
+ port should not signal an error if fseek generates an
+ ESPIPE -- the fseek operation actually "succeeded" in that it
+ reset the I/O direction flag for the FILE.
+
+ * repl.c (input_waiting): R4RS requires that "char-ready?"
+ return "#t" at end-of-file. The semantics for "ioctl(...,
+ FIONREAD, ...)" are such that it gives 0 on a socket that is
+ closed (on the other side of the connection). If the
+ system has select(), use that instead to get the correct
+ behavior.
+
+ * socket.c (l_listen): Treat sockets that have been "listened"
+ as input-ports. This allows polling for new connections
+ (e.g. with "char-ready?") instead of blocking in
+ "socket:accept".
+
+ * socket.c (l_accept): Fix type checking to agree with
+ previous patch.
+
+Wed Nov 13 17:11:59 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * sys.c (igc): fixed off-by-1 error for sizeof save_regs_gc_mark.
+ (gc_mark): fixed off-by-1 error for sizeof(CONTINUATION). These
+ seem to fix a very obscure GC bug.
+
+Tue Oct 29 10:47:41 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * Init.scm (exec-self): Added.
+
+ * repl.c (init_repl): DUMP sets RESTART to EXEC-SELF.
+
+Mon Oct 28 11:39:30 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * repl.c (tryload): Made tail-recursive so that dump, quit, exit,
+ etc. will work as the last expression in a loading file.
+ (scm_execpath): Split out from scm_unexec.
+
+Sun Oct 27 22:12:32 1996 Aubrey Jaffer <jaffer@localhost.bertronics.com>
+
+ * unexec.c: All Updated from emacs-19.34 -- no changes necessary.
+ * gmalloc.c:
+ * pre-crt0.c:
+ * ecrt0.c:
+ * unexelf.c: fixes Linux (ELF) dump bug.
+
+Mon Oct 21 21:49:20 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * build.scm (platform): linux renamed linux-aout. linux-elf fixed
+ and renamed linux.
+ (C-libraries): X11R6 moved library files on RedHat Linux. Linux
+ graphics library now has entry (doesn't default).
+ (compile-dll-c-files linux):
+ (make-dll-archive linux): Now converts from ".o" objects to ELF
+ ".so" form and "links" the usual libraries.
+
+ * Link.scm (usr:lib x:lib): dynamic linking fixed for (linux ELF)
+ dlopen. Libraries other than ".so" object not needed; eliminated
+ by usr:lib and x:lib returning #f.
+
+ * dynl.c (l_dyn_unlink): prints result of dlerror() on errors.
+
+Thu Oct 10 14:05:14 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * eval.c (nconc2last): If CAUTIOUS is defined, checks that
+ APPLY's arglist and last element of arglist are LIST?s.
+
+Sun Oct 6 16:40:54 1996 Radey Shouman <shouman@zianet.com>
+
+ * eval.c (unmemocar): The code in unmemocar to deal with ILOCs was
+ never being executed.
+
+Fri Oct 4 13:57:35 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * sys.c (igc): symhash GC can now be disabled with
+ #define NO_SYM_GC.
+
+Wed Oct 2 20:51:07 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * Init.scm (boot-tail): Added FSF --help and --version options.
+ Added --no-init-file as a synonym for -no-init-file.
+
+Sun Sep 29 23:59:19 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * scm.texi (File-System Habitat): improved wording and added
+ examples.
+
+Thu Sep 26 22:23:32 1996 Radey Shouman <shouman@zianet.com>
+
+ * sys.c (intern): fixed (new) symhash GC bug.
+
+Tue Sep 24 13:55:11 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * scm.texi (Top): Renamed sections.
+
+ * sys.c (mark_syms mark_sym_values): Split up mark_symhash() to
+ immunize against accidental pointers.
+
+Sat Sep 14 22:53:46 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * repl.c (gc_ports_collected): added to instrument symbol GC.
+
+Sat Sep 14 15:35:29 1996 Radey Shouman <shouman@zianet.com>
+
+ * sys.c (igc): Added calls to mark_symhash() and sweep_symhash().
+ These GC unused symbols with a top-level value of UNDEFINED.
+ (mark_symhash): added.
+ (sweep_symhash): added.
+
+Wed Sep 11 21:18:05 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * scm.texi (Debugging Scheme Code): Added section.
+
+Sat Aug 31 14:05:24 1996 Eric Hanchrow <erich@MICROSOFT.com>
+
+ * scm.c (l_sleep): Ported to Windows NT (_WIN32)
+
+ * ioext.c: Ported to Windows NT (_WIN32)
+
+Sat Aug 31 13:18:34 1996 Aubrey Jaffer <jaffer@martigny.bertronics>
+
+ * eval.c (definedp): Changed from a memoizing macro to a `syntax'.
+
+Sun Jul 21 01:06:44 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * Link.scm (link-named-scm): fixed to call "build.scm".
+
+Sat Jul 20 23:53:17 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * scm.texi (Memoized Expressions): section added.
+ (Errors): section added.
+
+Wed Jul 17 17:40:01 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * r4rstest.scm: renamed from "test.scm". Now carries copyright
+ notice suitable for single file distribution.
+
+Fri May 17 23:37:16 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * findexec.c (dld_find_executable): names changed to keep up with
+ DLD changes.
+
+Sun May 12 21:43:14 1996 Radey Shouman <shouman@zianet.com>
+
+ * unif.c (array_rank): Was returning 0 for bit-vectors.
+ (uve_fill): Fixed error report.
+ (lcount):
+ (position): Made to work with 1-d shared bit-arrays.
+ (aind): Added check for second argument, must be either
+ an INUM, NULL, or a pair. Without this, e.g.
+ (uniform-vector-set! <vector> 'x 0)
+ starts cdr'ing down the symbol ...
+ (array_inbp): Cleaned up to work with enclosed and huge arrays.
+
+ * gsubr.c (gsubr_apply): Fixed error report.
+
+ * scl.c (equal): Prevent fallthrough on last case, could cause
+ wierdness if cases are added later.
+
+ * ramap.c (ra_matchp): Fixed to allow any 1-d array of zero size
+ to match a uniform vector, and to require all non-zero length
+ dimensions of two arrays to match even after a zero length
+ dimension. Now promotes 0-d arrays as well as scalars to match
+ first array shape.
+ (sc2array): Reshapes 0-d arrays as well as scalars.
+ Added check to make sure 2nd argument is really an array,
+ vector or uve.
+ (ramapc): Changed to allocate fewer array headers when arguments
+ are 1-d arrays. (Still allocates more than strictly necessary.)
+ (array_copy): Added check for scalar destination argument, since
+ ra_matchp() will now promote scalars to arrays.
+
+Sun May 12 00:52:51 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * build.scm (build): fixed HP-UX compile-dll-c-files.
+
+ * findexec.c (dld_find_executable): ifdefed out stat() for hpux.
+
+ * scm.c: New const declarations rejected by hp-ux cc; ifdefed out.
+
+Thu May 9 10:28:14 1996 Tim Pierce <twpierce@midway.uchicago.edu>
+
+ * time.c sys.c findexec.c: string[s].h configuration for Solaris
+ 2.3 system using gcc 2.7.2.
+
+Tue Apr 9 19:46:21 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * sys.c (igc): stackbase argument added. Passing 0 disables stack
+ marking (used by dump).
+
+ * build.scm (build link-c-program djgpp):
+ (build compile-c-files djgpp): Uses new batch:apply-chop-to-fit to
+ deal with MS-DOS line length restrictions.
+
+Sun Apr 7 23:15:36 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * repl.c (repl_driver): now supports unexec conditionally by
+ CAN_DUMP.
+ (scm_unexec): moved from dump.c. Now throws to top level to avoid
+ saving continuations.
+
+ * dump.c: removed. Contents moved to repl.c.
+
+ * continue.c (dynthrow): One instruction interrupt vulnerability
+ removed for machines with long ints. Others define SHORT_INT.
+
+ * repl.c (repl_driver): Throws to top level now encoded by COOKIE
+ flags for non- SHORT_INT platforms.
+
+Sat Apr 6 14:29:47 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * unexec.c (A_TEXT_OFFSET A_TEXT_SEEK ADJUST_EXEC_HEADER NO_REMAP
+ TEXT_START HAVE_GETPAGESIZE SEGMENT_MASK): definitions moved from
+ scmfig.h.
+
+ * gmalloc.c (HAVE_GETPAGESIZE): copied definition here so that
+ scm.h and scmfig.h won't be included for just one definition.
+
+ * dump.c (scm_dump): reworked to use execpath as default second
+ argument. Removed "#include DUMP_CODE" abomination; using
+ suppress parameters in build.scm
+
+ * build.scm (build C-libraries): added dump (unexec) and nostart
+ libraries to support dump.
+ (build compile-commands): Added support for dump
+ (build features): dump
+
+ * scm.c (execpath): now a global which init_dump() also sets.
+
+ * repl.c (repl_driver): added scm_evstr("(boot-tail)") call
+ after scm_ldfile(initpath) so command-line arguments can be
+ processed after "Init.scm" is loaded.
+
+ * build.scm (build platform): added record for MS-DOS so defaults
+ don't cause errors when -p not specified.
+
+Mon Jan 9 15:43:36 1995 Patrick LECOANET <lecoanet%sid1@cenaath.cena.dgac.fr>
+
+ * dump.c (dump): created.
+
+ * pre-crt0.c crt0.c gmalloc.c unexec.c unexelf.c: adapted from
+ emacs (circa 1994).
+
+Fri Apr 5 00:16:59 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * ramap.c (ramapc ra2contig array_imap): Added +0L to cast first
+ argument to make_uve() to long.
+
+Thu Apr 4 00:47:09 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * ramap.c: removed #ifdef ARRAYS (over whole file).
+
+Wed Apr 3 10:14:18 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * Link.scm (compile-file): Now calls build.scm for compiling C.
+
+ * hobbit.scm ("auxiliary functions" butlast ...): removed and
+ renamed gratuitous (and incompatible) duplications of
+ slib/comlist.scm.
+
+Mon Apr 1 08:56:09 1996 Johann Friedrich Heinrichmeyer <Fritz.Heinrichmeyer@fernuni-hagen.de>
+
+ * sys.c (stack_check): sizeof(STACKITEM) was multiplied on wrong
+ side of inequality.
+
+Fri Mar 29 23:52:03 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * patchlvl.h (SCMVERSION): 4e4
+
+ * build.scm (build): microsoft-c-nt support added.
+
+ * scm.c (l_raise): Disabled for WINDOWS_NT.
+ (scm_find_impl_file): fixed for getenv("SCM_INIT_PATH") case.
+
+Sun Mar 24 00:18:10 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * build.scm (build): fixed -tdll to not make archive or compile
+ all 'linkable files.
+
+Sun Mar 10 17:23:39 1996 Radey Shouman <shouman@ccwf.cc.utexas.edu>
+
+ * ramap.c (sc2array): Added, converts a scalar to a shared array.
+ (ramapc): Uses sc2array to convert scalar arguments to arrays
+ for ARRAY-MAP! &c.
+ (ura_read, ura_write, ura_fill): Added.
+ (array_map): Added check for number of arguments when procedure
+ arg is a subr. Added cclo case.
+
+ * unif.c (dims2ura): Fixed, it wasn't properly filling its result
+ sometimes. Added range check for size of conventional arrays.
+ (aind): Added range check when called as subr3.
+ (array_inbp): Returns #t if called with a scalar and no
+ index args -- APLish boundary case.
+ (cvref): Now recycles enclosed array refs.
+ (aset): Uses num2dbl for setting inexact array elts, so
+ e.g. (array-set! <inexact-array> 0 ...) works.
+ (array_contents): For strict option, wasn't returning an array
+ whenever the base was non-zero, now less restrictive.
+ (ra2contig): moved to ramap.c, as it calls ramapc(). To allow
+ dynamic linking of ramap.c.
+ (rafill): moved from ramap.c, to allow filling of arrays on
+ creation without needing ramap.c.
+ (uve_fill): Added, for filling uves / 1-d arrays without needing
+ ramap.c.
+ (uve_read, uve_write): (Re)added
+ (ura_read, ura_write): Moved to ramap.c, now call uve_[read write].
+ (ra2l): uses cvref instead of aref, maybe faster and works for
+ enclosed arrays.
+ (init_unif): Added feature 'string-case, to prevent require
+ from nuking STRING-UPCASE!, STRING-DOWNCASE!
+ (encl_array): Added range check for dimension args.
+
+ * rope.c (num2dbl): Added, analogous to num2dbl.
+
+ * scmfig.h Eliminated redundant #ifdef
+
+ * scl.c (makdbl) Rearranged so that it tests for out of range
+ double argument before assigning to float variable, this
+ avoids causing SIGFPE on my Linux box.
+ (equal): Fixed so that it doesn't need extern array_equal,
+ allowing ramap.c to be dynamically linkable.
+
+ * scm.c Added documented variable *scm-version*
+
+Thu Mar 21 00:14:29 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * Link.scm (scm:object-suffix): Changed to ".so" when
+ 'sun-dl is PROVIDED?.
+
+ * scmfig.h (getcwd): addition for scmconfig.
+ * findexec.c: minor change for scmconfig.
+
+Wed Mar 20 00:12:43 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * README (Making SCM with Think C 4.0 or 4.1): Instructions added
+ back in.
+
+Sun Mar 17 00:17:21 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * findexec.c (dld_find_executable): Added support for ~ and ~/ in
+ PATH environment variable.
+
+Sat Mar 16 10:38:15 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * scm.c (scm_find_impl_file): Added generic_name argument to test
+ for cases where executable *doesn't* have its usual name.
+ (scm_sep_init_try): Added combined function to reduce length of
+ scm_find_impl_file.
+ (scm_try_path): Now tests for (and returns) 0.
+
+ * build.scm (build): fixed assorted bugs.
+
+Tue Mar 12 12:48:28 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * 4e3: released.
+ * repl.c (read_token): ',' now delimits token.
+
+Mon Mar 4 23:19:50 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * scm.texi (SLIB and require.scm): SLIB installation and
+ "require.scm" trampoline configuration method explained.
+
+ * Init.scm (load:pre load:post): added to share code between
+ scm:load and scm:load-source. "require" is now loaded using the
+ regular calls; trying to maintain SCM initializing without SLIB is
+ too hard.
+
+Sun Mar 3 10:59:23 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * build.bat: Added for MS-DOS.
+
+Fri Mar 1 23:47:57 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * scm.texi (Line Editing): html-linked readline and editline ftp
+ sites.
+
+ * build.scm: Added support for edline.
+
+Wed Feb 28 23:39:55 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * build.scm (build:build): library field `supress-files' added.
+ Used for supressing "findexec.c" when DLD is present.
+
+Sun Feb 25 00:29:47 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * scm.c (scm_find_impl_file): Tries hard to find Init.scm in
+ implementation vicinity.
+ (scm_try_path scm_cat_path): used by scm_find_impl_file.
+ (main): Changed to use scm_find_impl_file() and free pathnames
+ before exit.
+
+Wed Feb 21 23:27:43 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * findexec.c (dld_find_executable): extracted from DLD for
+ general use.
+
+Tue Feb 20 00:08:29 1996 Jochen Schwarze <schwarze@isa.de>
+
+ * Init.scm (*vicinity-suffix*): Now includes #\/ for MSDOS,
+ etc. (GCC support).
+ (library-vicinity): Now set from implementation-vicinity if
+ environment variable SCHEME_LIBRARY_PATH is not defined.
+
+ * scm.c (SYSTNAME): not redefined with DJGPP (both MSDOS and
+ unix).
+
+Sun Feb 18 09:29:57 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * subr.c (divbigint): fixed sign bug for 0 return value.
+
+Sun Feb 18 00:29:43 1996 Per Bothner <bothner@cygnus.com>
+
+ * gsubr.c (gsubr_apply): elided gratuitous make_vector call.
+
+Sat Feb 17 11:50:41 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * Init.scm (*features*): string-case added.
+ (string-upcase string-downcase string-capitalize): added.
+
+ * unif.c (strcap): string-capitalize!
+
+ * sys.c (sysintern): Now looks for (and uses) symbol already
+ created. This will eliminate order of linking and loading
+ dependencies.
+
+Tue Sep 26 20:37:25 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Evaluation): Enlarged description to include type
+ folding.
+ (Cells): Split Node Cells into Header, Subr, Ptob, and Smob Cells.
+
+Fri Sep 22 22:31:13 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c scmfig.h (WINDOWS_NT): support added. But what flag does
+ Windows NT #define?
+
+Sun Sep 10 13:37:44 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (scm_stack_trace): Added Scheme call "stack-trace" to
+ print stack from exception handlers.
+ (everr): Now processes all exceptions before longjmping to
+ rootcont #ifdef CAUTIOUS.
+
+ * Init.scm (user-interrupt): If stack-trace available, prints
+ stack-trace and enters breakpoint.
+ (break): Autoloaded.
+
+Mon Aug 7 12:52:15 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (stacktrace): now a sys_protect.
+
+ * subr.c (ilength): differentiated negative return codes;
+ non-terminating returns -1, not a list -2.
+
+Sat Aug 5 18:50:11 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (scm_print_stack): added. Called by def_err_response.
+
+ * eval.c (ceval): SCM stacktrace variable maintained and saved
+ in CONT(cont)->other.stacktrace. Under CAUTIOUS flag,
+ checkargs1 label added to check special single argument calls.
+
+Wed Jul 26 23:26:21 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (char_readyp): Now looks for BUF0 flag to determine if
+ input_waiting() possible.
+
+ * scm.c (init_scm run_scm main): BUF0 flag now set on cur_inp
+ to indicate whether CHAR-READY? will work.
+
+Wed Jul 19 13:25:01 1995 Shigenobu Kimura <skimu@komachi.phys.s.u-tokyo.ac.jp>
+ * dynl.c (l_dyn_main_call): Arguments to main (in DLD section)
+ were reveresed! Added hpux l_dyn_main_call.
+
+Sat Jul 8 22:23:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (scm:load): Internal define dependency problem fixed.
+ Variable *interactive* set for invocation without options.
+
+ * scm.texi: Guile WWW and citation added.
+
+ * subr.c: logical (2's complement) operations rewritten to now
+ work with bignums. Logical procedure names changed to conform
+ with Guile convention.
+
+Fri Jun 9 13:47:58 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * continue.c (stack_size):
+ (make_root_continuation):
+ (make_continuation):
+ (free_continuation):
+ (throw_to_continuation): moved from sys.c to make possible library
+ module.
+
+ * continue.h: created from setjump.h
+
+ * scm.texi (Compiling And Linking): Documented l_dyn_main_call.
+ (Type Conversions): added rope.c documentation.
+ (Callbacks): split from "Calling Scheme From C".
+ (Continuations): Rewritten to describe new "continue.c"
+
+Fri May 19 01:32:12 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * *.c: converted applicable uses of makfromstr with strlen to
+ makfrom0str.
+
+ * rope.c: new
+ (scm_addr): added.
+ (num2long num2ulong num2ushort num2uchar ulong2num long2num):
+ moved from scl.c and elsewhere.
+ (makfromstrs makfrom0str makfromstr): moved from sys.c and posix.c
+ (must_free_argv): new
+ (scm_ldprog scm_ldfile scm_ldstr scm_evstr): moved from repl.c
+ (makargvfrmstrs): chopped out of i_execv in ioext.c.
+ makargvfrmstrs isn't really done correctly; it is GC leaky.
+ It should return a SMOB which can be GCed, but this makes this
+ C interface harder to use.
+
+ * dynl.c (l_dyn_main_call): added procedure to call
+ dynamically linked procedure with string arguments converted
+ to argv and argc. Written only for DLD. Needs to be repeated
+ for other dynamic linking regimes.
+
+Tue Apr 25 10:24:42 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (make_string): Was silently failing for illegal 2nd args!
+
+Sat Apr 15 23:18:47 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (catalog:add-link): When feature is already in catalog,
+ will only add new feature association to catalog if file exists.
+
+Sun Apr 9 22:59:46 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (repl_driver): Now closes load port when ABORTing.
+
+Sat Apr 8 21:35:43 1995 Aubrey Jaffer (jaffer@jacal)
+
+ From: Tom Lord <lord@cygnus.com>
+ * scm.texi:
+ Tcl Facilities:: Mutual calling between Tcl and Scheme.
+ Tk Facilities:: Accessing Tk from Scheme.
+ Gwish:: A Wish-like application of Guile.
+ System Calls:: Psst. Wanna write a manual section?
+ Gscsh:: Shell and systems programming features.
+
+ From: chen@adi.com (Franklin Chen)
+ * scm.c (l_raise): uses raise() ifdef STDC_HEADERS, otherwise
+ kill().
+
+ From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
+ * scl.c (istr2int): Fixed complaints of overflow on octal numbers
+ >= 2^BITSPERDIGIT. Patch should make this work for all radix 2 <=
+ radix <= 16.
+ (num2ulong): Makes it work for negative bignum argments, and
+ adds an overflow check.
+
+ * ramap.c unif.c: There are several places in ramap.c, and
+ raprin1() in unif.c, where I had assumed that an ivect or uvect
+ elt would be representable no larger than an INUM. This patch
+ should fix these, also adding overflow checking for array
+ arithmetic on uvects and ivects.
+
+ Also, fixes aref, which assumed that if its argument was a smob
+ that it was an array. Changes cvref to return a real number when
+ the imaginary part of an elt is 0.
+
+Sat Mar 25 20:37:48 1995 Aubrey Jaffer (jaffer@jacal)
+
+ From: Don Bennett <dpb@netcom.com>
+ * rgx.c: rewritten and extended. The compile function now takes a
+ string of optional flags. New operations specific to the GNU
+ regex library is conditionalized with _GNU_SOURCE.
+
+ From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
+ * Iedline.scm ((make-edited-line-port)):
+ * edline.c (lreadline): Added Gnu `readline' input editing
+ (get ftp.sys.toronto.edu:/pub/rc/editline.shar).
+
+ * unif.c (ra2contig): Fix a nasty bug ra2contig() (used for
+ UNIFORM-ARRAY-WRITE / READ!) that produced arrays with undersized
+ contents vectors.
+
+ * eval.c (apply): Fix so that (APPLY <cclo> '()) works properly.
+
+ * gsubr.c (make_gsubr): Give the arg number ASSERTion the right
+ sense.
+ (gsubr_apply): Add an ASSERTion to check for too many arguments.
+ (gsubr_apply): Take the address of the temporary vector, so as to
+ prevent its being optimized away and allowing gc of the vector.
+ (This happened with Cray cc in the MAP and FOR-EACH code; I'm no
+ longer able to find out if it would happen there.)
+
+Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (I/O-Extensions): Finished.
+
+ * Init.scm (scm:load): `loading' messages now indented.
+
+Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi: documentation finished for "posix.c" and "unix.c".
+
+ * posix.c (scm_getgroups): added.
+
+ * posix.c (makfrom0str): According to glibc.info, some field in
+ structures like pwent may have NULL pointers. Changed makfrom0str
+ to return BOOL_F in this case.
+
+Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware
+ HighC ported.
+
+ * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was
+ __STDC__). This allows an overly fussy compiler to still have
+ __STDC__.
+
+ From: dorai@ses.com (Dorai Sitaram)
+ * ioext.c (l_utime): include files fixed for __EMX__
+
+Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it
+ gets used for non-GCed strings in scm_evalstr scm_loadstr.
+ (mkstrport cwos cwis): changed so caller's name is passed into
+ mkstrport().
+
+ * repl.c
+ (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added
+ for easier C to scheme callbacks.
+ (loadport): variable added so lreadr() and flush_ws()
+ increment linum only when reading from the correct port.
+ (def_err_response): now handles ARGn for argument numbers > 5 and
+ unknown position arguments.
+
+ * dynl.c: Dynamic Linking now sets and restores *load-pathname*
+ around the init_ call.
+
+Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c.
+ (add_feature): moved from repl.c.
+ (features): init table removed (caused multiple symbols).
+
+Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (scm_init_extensions COMPILED_INITS): Added so that
+ statically linked, compiled code can be initialized *after* most
+ of Init.scm has loaded.
+
+Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (append): Added check for bad arguments and fixed errobj.
+
+Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (exec execp): changed so that 2nd arguments is argv[0]
+ (like posix) and renamed to execl and execlp.
+ (execv execvp): added.
+
+Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (lexec): moved from repl.c and scm.c.
+ (lexecp i_exec l_putenv): added.
+
+ * posix.c (open_pipe l_open_input_pipe l_open_output_pipe
+ prinpipe): moved from ioext.c.
+ (l_fork): added.
+
+Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2long long2num): moved here from subr.c.
+ (num2ulong): fixed (< to >=) bug.
+
+ * unif.c (aset array2list array_ref cvref): uniform integers and
+ unsigned integer arrays now handle full size integers (and
+ inexacts) using num2long, num2ulong, long2num, and ulong2num when
+ INUMS_ONLY is not defined.
+
+ * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers.
+
+Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Overview): scm.1 converted to texinfo format and
+ incorporated.
+
+Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Internals): code.doc converted to texinfo format.
+ Much added and reorganized. code.doc removed.
+
+Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (logbitp logtest): added.
+
+Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2ulong): checks for bignum sign and magnitude added.
+
+ * subr.c (logand logior logxor lognot): lognot restriction to
+ INUMs removed. Logand, logior, and logxor now will work for up to
+ 32 bit signed numbers.
+
+Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (def_err_response): Circuitous call to quit() replaced
+ with exit(EXIT_FAILURE);
+ (everr): Now calls def_err_response() in interrupt frame if
+ errjmp_bad or there are dynwinds to do. This prevents silent
+ failure in batch mode.
+
+Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Trouble Shooting): Section converted from README.
+
+ * Init.scm (-d filename): option added which does:
+ (begin (require 'database-utilities) (open-database filename))
+
+ * repl.c (handle_it): Now discards possibly used top freelist cell
+ for GC safety. Also now just punts if errjmp_bad.
+
+ * scm.texi: converted from MANUAL. GUILE documentation merged in.
+
+Tue Jan 3 15:09:36 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (SYSTNAME): msdos changed to ms-dos. windows added.
+ archimedes changed to acorn.
+
+ From: jon_seymour@vnet.ibm.com (jon seymour)
+ * scmfig.h: defined LACK_TIMES and STDC_HEADERS if __IBMC__ is
+ defined.
+
+ * sys.c: #include <io.h> and #include <direct.h>. define ttyname()
+ macro.
+
+ * scm.c: #include <io.h> and compile out execvp() call.
+
+ * time.c: #include <sys/timeb.h>
+
+ * makefile.os2: makefile for use with OS/2 toolkit nmake.
+
+Sun Jan 1 21:17:36 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c Link.scm: names unified. Libraries for HP-UX fixed.
+ HP-UX dll suffix now ".sl".
+
+ From: Shigenobu Kimura <skimu@komachi.phys.s.u-tokyo.ac.jp> *
+ dynl.c (fcall): Fixed dynamic linking on hp9000s700 (or 720) HP-UX
+ 9.01 or 9.03.
+
+Wed Dec 7 21:19:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (l_open_input_pipe, l_open_output_pipe): moved from
+ "Init.scm".
+
+Mon Dec 5 16:55:21 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (i_setbuf0): added.
+ (open_file): `0' in mode string now controls the buffered-ness of
+ returned port.
+
+ * Init.scm (slib:load-compiled): no longer silently fails if other
+ than the first argument does not link correctly.
+
+ From: Robert Sanders <rsanders@hrothgar.mindspring.com>
+ * ioext.c (l_write_line): moved from "Init.scm".
+
+Sun Dec 4 21:47:08 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (free_storage): lord@cygnus.com pointed out that candle
+ was being burnt from both ends. Loop fixed. Mallocs either
+ leaking or counted wrong.
+
+Sat Dec 3 22:32:59 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * code.doc: added description of compiled closures.
+
+Thu Nov 24 23:10:31 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * socket.c (l_socketpair): added. Both make-stream-socketpair and
+ make-stream-socket now take optional prototype argument.
+
+Tue Nov 22 00:16:05 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * ramap.c (ramapc and friends): moved from unif.c to get source
+ file sizes below 64k.
+
+Mon Nov 21 00:44:32 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * posix.c (l_pwinfo grinfo): made to work like network inquiry
+ procedures (no args steps through entries).
+ (l_setgr l_setpw l_uname): added.
+
+ From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
+ * gsubr.c (make_gsubr gubr_apply): allows arbitrary (< 11)
+ required, optional, and rest arguments to compiled functions.
+
+Sun Nov 20 11:59:18 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * socket.c MANUAL: most Scheme names for socket functions changed
+ for consistency.
+ * socket.c (socket:shutdown): added. I can't imagine what use
+ shutdown provides. SOCKETs can be closed like any other port.
+ Should socket:shutdown SOCKETs be closed? Does having shutdown
+ sockets cause file descriptors to be reused? Socket:shutdown will
+ be removed if no use is found for it.
+ (tc16_sknm): added to encapsulate information retrieved from
+ getpeername and getsockname.
+ (socket-name:family socket-name:port-number socket-name:address):
+ added to retrieve information from tc16_sknm.
+ (inet:string->address inet:address->string inet:network
+ inet:local-network-address inet:make-address): added.
+ (gethost sethostent getnet getnetent getproto setprotoent getserv
+ setservent): inquiry procedures added.
+
+ * sys.c (makfromstrs(argc, argv)): added. converts C array of
+ strings to SCM list of strings. If argc < 0, a null terminated
+ array is assumed.
+
+Sat Nov 19 00:20:58 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (l_proc_doc): added procedure-documentation.
+
+Fri Nov 18 23:34:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * build.scm (scm:build): Added. Replaces system specific
+ makefiles.
+ * ccnfigdb.scm: Database of system specific compile, link, and
+ archive procedures and library information.
+
+Thu Oct 27 12:57:02 1994 Jerry D. Hedden <hedden@esdsdf.dnet.ge.com>
+
+ * ioext.c: conditional code for vms and version (3.6) of Aztec C.
+ * pi.scm ((e digits)): Modified 'bigpi' for slight speed
+ improvement. Added function to calculate digits of 'e'.
+
+Wed Oct 26 11:22:05 1994 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scl.c (round): Now rounds as described in R4RS.
+
+ * test.scm (test-inexact): test cases for round.
+
+Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (grow_throw lthrow dynthrow): now pass arrays, check
+ for adequate growth, and clear out register windows (on sparc).
+
+Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (ttyname fileno): added.
+
+Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (symlink readlink lstat): added.
+
+ * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed.
+
+ * ioext.c (read-line read-line! file-position, file-set-position
+ reopen-file open-pipe opendir readdir rewinddir closedir chdir
+ umask rename-file isatty? access chmod mkdir rmdir stat utime
+ raise): moved from "repl.c" and "sys.c".
+
+Fri Oct 21 21:19:13 1994 Radey Shouman <shouman@ccwf.cc.utexas.edu>
+
+ * unif.c (ra2contig): now has a second parameter to indicate
+ whether copying is necessary or not. Eliminates gratuitous copy
+ by UNIFORM-ARRAY-READ! when called with a noncontiguous array.
+
+ (array_map): more liberal check on when ARRAY-MAP! can use
+ array-ified asubrs.
+
+Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (opendir readdir rewinddir closedir reopen-file): added
+ under IO_EXTENSIONS.
+
+Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (badargsp): added under ifndef RECKLESS to check @apply
+ and apply() arg counts.
+
+Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (mknod acct nice sync): added.
+
+ * socket.c (socket bind! gethost connect! listen! accept): added.
+
+ * time.c (utime): added under IO_EXTENSIONS.
+
+Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (getcwd umask access chmod mkdir rmdir): added
+ under IO_EXTENSIONS.
+
+ * scm.c (l_pause): added if SIGALRM defined.
+ (l_sleep): added if SIGALRM not defined.
+
+ * scl.c (num2ulong): added. Used in "time.c"
+
+Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (access chmod): Posix access added under IO_EXTENSIONS.
+
+Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id,
+ set*id): added.
+
+ * time.c (l_raise l_getpid): added
+ * subr.c (ulong2big):
+ * scl.c (ulong2num): useful routines for system call data
+ conversion moved from "time.c".
+
+Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (big2inum): (more accruately) renamed from big2long.
+
+Mon Aug 29 11:36:46 1994 Radey Shouman <rshouman@hpcf.cc.utexas.edu>
+
+ * unif.c: This is a large patch, but also a bit larger than it
+ appears -- I moved a few function definitions around to eliminate
+ gratuitous forward references.
+
+ * unif.c repl.c (raprin1): Combined print routine for arrays with
+ that for uves.
+
+ * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general
+ arrays, by copying when necessary, renamed them to
+ UNIFORM-ARRAY-READ! and -WRITE.
+
+ * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d
+ array even when the stride in the last dimension is greater than
+ one, gave it an optional second argument STRICT, which makes it
+ behave as it did before, returning an array/vector only if the
+ contents are contiguous in memory.
+
+ * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use
+ (lambda (ra) (array? (array-contents ra #t)))
+
+ * unif.c code.doc (ramapc): unrolls arrays mapping into one loop
+ if possible, to make this quick, changed the format of the array
+ CAR, now uses one bit to indicate that an array is contiguous --
+ this still allows a ridiculous number of dimensions.
+
+ * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I
+ moved the typedef for dsubr and #define for DSUBRF to scm.h
+
+ * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs
+ may be mapped without going through apply(), saving time and
+ reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped
+ directly as special cases -- for uniform arrays this is nearly as
+ fast as the equivalent C, and doesnt' cons. I've made sure that
+ +, -, *, and / vectorize on the CRAY, this may be wasted effort
+ but the effort is not great.
+
+ * unif.c (ARRAY-COPY!) now copies many arrays of differing types
+ to each other without going through the aref/aset, e.g. float ->
+ double, double -> complex, integer -> float ... This should make
+ array type coercions for arithmetic faster.
+
+ * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array
+ that is the transpose of its first argument. I think this does
+ what an APL:TRANSPOSE would.
+
+ * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks
+ like an array of shared arrays, the difference being that the
+ shared arrays are not actually allocated until referenced.
+ Internally, the contents of an enclosed array is another array.
+ The main reason for this is to allow a reasonably efficient
+ implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to
+ actually make an array of shared arrays, just use ARRAY-COPY!.
+
+ * unif.c (cvref): Created internal version of aref(), cvref() that
+ doesn't do error checking; Thus speeding things up. Profiling of
+ SCM running array code revealed that aref() was taking a
+ surprising fraction of the CPU time
+
+ TO DO:
+
+ The mechanism for looking up the vectorized functions is a little
+ kludgy, I was tempted to steal some of the CAR of the subr type to
+ encode an offset into a table of vectorized functions, but this
+ would make it more likely that dynamically loaded subrs lose thier
+ names.
+
+ It is almost possible to write APL:+ and friends now, it is just
+ necessary to figure out the appropriate type of the returned array
+ and allocate it, and to promote scalar arguments to arrays (with
+ increments 0).
+
+ This doesn't include vectorized REAL-PART, IMAG-PART,
+ MAKE-RECTANGULAR ...
+
+ I think some C support for APL:REDUCE and maybe INNER-PRODUCT will
+ be needed for a reasonably fast APL.scm
+
+ unif.c is getting quite big, time to split it up?
+
+
+Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm repl.c (quit): code was not using return values
+ correctly.
+
+Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * record.c (init_record): remaining record functions moved into C
+ code.
+ * eval.c sys.c: compiled closures now conditional under CCLO.
+
+Sat Aug 20 23:03:36 1994 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * eval.c (ceval apply):
+ * sys.c (makcclo): tc7_cclo, compiled closures, now supported.
+ * record.c (init_record): C implementation of slib "Record"s using
+ CCLO.
+ * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for
+ bignums with DIGSTOOBIG defined. Also, changed the return type of
+ longdigs() to void, since that value is no longer used anywhere.
+
+Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (curtime): replaces get-universal-time. Other time
+ functions removed (SLIB support more complete).
+
+ * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400
+ bug. Also added to test.scm.
+
+Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically
+ (ldso) linked libc.sa and libm.sa (under Linux).
+
+Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (array-fill!): bug with increment in default clause fixed.
+ Fast string support added.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c (array-fill! array-for-each): bug fixes.
+
+Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (run_scm init_scm): "-a" heap allocation argument supported.
+
+ * Makefile (proto.h): removed.
+
+ From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au
+ * scm.h (P): Conditionalized ANSI'fied version of the scm.h.
+
+Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (usr:lib lib): Now checks for shared libraries
+ (lib*.sa) first.
+
+Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c scm.c: Support for compilation under Turbo C++ for Windows
+ (system and exec disabled) added under C flag "_Windows".
+
+Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * test.scm ((test-delay)): added.
+ ((test-bignum)): added and called automatically if bignums
+ suported. test-inexact called automatically if inexacts
+ supported.
+
+Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (trace untrace): moved to SLIB/trace.scm.
+
+Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm: Autoload for hobbit now does (provide 'hobbit). This
+ allows hobbit to know if it is self compiling (although reloads of
+ hobbit will not be quite right).
+ ((compile file . args)): removed.
+
+ * makefile.unix (proto.h): removed.
+
+ * Transcen.scm: compile-allnumbers HOBBIT declaration added.
+ Init.scm will now load compiled Transcen.o.
+
+ * scm.h: HOBBIT section removed.
+
+ * README (SLIB): Now strongly recommends getting SLIB and lists
+ ftp sites.
+
+ * eval.c (m_delay): fixed bug with multiple sets of (delay x).
+
+Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (makflo): shortcut for single precision float arrays
+ added.
+
+Fri Apr 15 00:54:14 1994 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * unif.c: no longer uses pointer comparisons in loops. Should
+ fix problems on 8086 processors.
+ * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared
+ arrays with only 1 element in some direction may still be
+ ARRAY-CONTIGUOUS?
+ (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE,
+ UNIFORM-ARRAY_READ!. Now they do the right thing for shared
+ bit-arrays not starting at the beginning of their contents vector.
+ (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a
+ shared, contiguous, 1-d array, instead of a vector, if the array
+ cannot access all of the contents vector. ARRAY-SIMPLE? removed.
+ (array-fill!): a replacement and generalization of
+ UNIFORM-VECTOR-FILL!.
+ (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL?
+ ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are
+ uniform vectors or if all are arrays. It differs from EQUAL? in
+ that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector.
+ for example
+ (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1)
+ (equal? '#(0 1) sh) ==> #F
+ (array-equal? '#(0 1) sh) ==> #T
+ (list2ura): Combines list2uve() and list2ura().
+
+Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (LACK_FTIME LACK_TIMES): defined for vms.
+
+Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (copytree): now copies vectors as well.
+
+ * repl.c (quit): now accepts #t and #f values.
+
+Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (repl): call to my_time() moved to not include READ time.
+
+ * time.c (mytime): now prefers to use times() over clock().
+ Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is
+ moved between machines.
+
+Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (*SCM-VERSION*): added.
+
+ * Makefile (intro): Added message for those who just make.
+ Cleaned up and reorganized Makefile.
+
+ * patchlvl.h (PATCHLEVEL): removed. Whole version now just in
+ SCMVERSION.
+
+Wed Mar 23 00:09:51 1994 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * repl.c (iprin1): Characters higher than 127 print as
+ #\<octal-number>.
+
+ * Init.scm ((read:array digit port)): added. Most # syntax
+ handled in read:sharp.
+
+ * unif.c (clist2uve clist2array): removed.
+
+Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu)
+
+ * sys.c (sfgetc): can now return EOF.
+
+Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * patchlvl.h (SCMVERSION): 4e0
+
+ * scmfig.h: was config.h (too generic).
+
+ * scm.c (main run_scm) repl.c (repl_driver init_init): now take
+ initpath argument. IMPLINIT now used in scm.c
+
+Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation
+ special form for tail recursive call-with-current-continuation
+ added. call_cc() routine removed.
+
+Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply
+ special form for tail-recursive apply added. ISYMs reactivated.
+
+Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * crs.c (nodelay): added. In NODELAY mode WGETCH returns
+ eof-object when no input is ready.
+
+ * Init.scm ((read:sharp c port)): defined to handle #', #+, and
+ #-.
+
+ * repl.c (lreadr): Now calls out to Scheme function read:sharp
+ when encountering unknown #<char>.
+
+Tue Feb 15 01:08:10 1994 Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp>
+
+ * eval.c (ceval apply): under flag CAUTIOUS, checks for applying
+ to non-lists added.
+
+Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (sym2vcell intern sysintern): now use internal strhash().
+
+ * scl.c sys.c (hash hashv hashq strhash()): added.
+
+Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to
+ #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next.
+
+Fri Feb 4 23:15:21 1994 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * unif.c: 0d arrays added. Serial array mapping functions and
+ ARRAY-SIMPLE? added.
+
+Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (LENGTH): now does unsigned shift.
+
+Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (*catalog*): catalog entries for db (wb),
+ turtle-graphics, curses, regex, rev2-procedures, and
+ rev3-procedures added.
+
+Sun Jan 30 19:25:24 1994 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * sys.c eval.c setjump.h setjump.s (longjump setjump): full
+ continuations now work on Cray YMP.
+
+Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for
+ modern linux.
+
+Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: ucs3028@aberdeen.ac.uk (Al Slater)
+ * makefile.acorn repl.c (set_erase): Port to acorn archimedes.
+ This uses Huw Rogers free unix function call library for the
+ archimedes - this is very very widely available and should pose no
+ problem to anyone trying to find it - its on every archimedes ftp
+ site.
+
+ From: hugh@cosc.canterbury.ac.nz (Hugh Emberson)
+ * dynl.c Link.scm: Dynamic Linking with SunOS.
+
+Thu Jan 6 22:12:51 1994 (jaffer at jacal)
+
+ * sys.c (gc_mark mark_locations): now externally callable.
+
+Sun Jan 2 19:32:59 1994 fred@sce.carleton.ca (Fred J Kaudel)
+
+ * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems
+ (K&R C does not allow initialization of "automatic" arrays or
+ structures). This was not use in 4d2 or previously, and the
+ following patch ensures that such initialization only occurs for
+ ANSI C compilers (Note that K&R C compilers need to explicitly
+ assign the values).
+
+Sat Dec 18 23:55:30 1993 (jaffer at jacal)
+
+ * scm.1 scm.doc (FEATURES): improved and updated manual page.
+
+ * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read
+ as ( and ) in forms.
+
+Wed Dec 8 23:13:09 1993 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * unif.c: More array fixes and functions.
+
+Tue Dec 7 00:44:23 1993 (jaffer at jacal)
+
+ * dynl.c (dld_stub): removed since dld is working better on Linux.
+
+Wed Dec 1 15:27:44 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): explicit cast added to get rid of compiler
+ warnings.
+
+ From: bh@anarres.CS.Berkeley.EDU (Brian Harvey)
+ * repl.c (repl) output newlines when more than one form on a line
+ for Borland C.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array fixes and documentation.
+
+Mon Nov 29 01:06:21 1993 rshouman@chpc.utexas.edu (Radey Shouman)
+
+ * unif.c: More array functions (need documentation).
+
+Sun Nov 28 01:34:22 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): returns a pointer to nullstr if offset is 0.
+
+ * subr.c eval.c (make_synt make_subr): now check that offset from
+ heap_org hack works for each subr. If not, 0 is used.
+
+ * Link.scm (compile-file): compiles SCM file to object suitable
+ for LOAD.
+
+ * Link.scm: initialization file created with Scheme code for
+ compilation and linking. LOAD now automatically loads SCM object
+ files.
+
+ * dynl.c Init.scm: dynamic linking now works under DLD on Linux.
+ Wb, crs, and sc2 can by dynamically loaded.
+
+Thu Nov 25 22:58:36 1993 (jaffer at jacal)
+
+ * sys.c (ltmpnam): return value of mktemp call tested in accord
+ with HP-UX documentation (returns "" on error).
+
+ * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc)
+ replaced with function versions. Control-C interrupts should work
+ while pending input on all systems again.
+
+Tue Nov 23 01:18:35 1993 dorai@cs.rice.edu (Dorai Sitaram)
+
+ * repl.c sys.c time.c config.h: MWC (Mark Williams C) support.
+
+Sun Nov 7 10:58:53 1993 "Greg Wilson" <Greg.Wilson@cs.anu.edu.au>
+
+ * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is
+ #defined, ticks and tick-interrupt work like alarm and
+ alarm-interrupt, but with units of evaluation rather than units of
+ time.
+
+Mon Nov 1 18:47:04 1993 (jaffer at jacal)
+
+ * unif.c (uniform-vector-ref => array-ref): integrated arrays
+ with uniform-vectors. Strings, vectors, and uniform-vectors
+ now just special case of arrays (to the user).
+
+Fri Oct 29 01:26:53 1993 (jaffer at jacal)
+
+ * unif.c (rasmob tc16_array): arrays are now a smob.
+
+Thu Oct 28 01:21:43 1993 (jaffer at jacal)
+
+ * sys.c repl.c (igc gc_start): GC message gives reason for GC.
+
+Wed Oct 27 10:03:00 1993 (jaffer at jacal)
+
+ * config.h (SICP): flag makes (eq? '() '#f) and changes other
+ things in order to make SCM more compatible with Abelson and
+ Sussman's book.
+
+ * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from
+ must_malloc would collect the tc_free_cell already allocated.
+
+ * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT):
+ modified to call igc when malloc usage exceeds mtrigger (idea from
+ hugh@ear.MIT.EDU, Hugh Secker-Walker).
+
+ From: Jerry D. Hedden
+ * pi.scm (bigpi): bignum version of pi calculator.
+
+Tue Oct 26 18:41:33 1993 (jaffer at jacal)
+
+ * repl.c (room): added procedure for printing storage statistics.
+
+Sun Oct 24 22:40:15 1993 (jaffer at jacal)
+
+ * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added.
+ * sys.c (stack_check): added.
+
+Sat Oct 23 00:08:30 1993 (jaffer at jacal)
+
+ * sys.c (mallocated): added to keep track of non-heap usage.
+
+ * sys.c (igc): fixed interrupt vulnerabilities around gc.
+
+Sun Oct 17 13:06:11 1993 (jaffer at jacal)
+
+ * repl.c (exit_report): added. Prints cumulative times if
+ (verbose > 2). Called from free_storage().
+
+ * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work
+ again. Other annoying CR behaviour fixed.
+
+ * time.c (init_time your_base my_base): now not reset when
+ restarting so timing numbers for restarting are correct.
+
+ * scm.h (sys_protects): rearranged.
+ * sys.c (tmp_errp): now a statically allocated global variable,
+ used by init_storage and free_storage.
+ * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport):
+ now #defines (which must correspond to order of newptob calls).
+
+Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README.unix configure configure.in scmconfig.h.in
+ mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built
+ using GNU autoconf. Put in scmconfig4c5.tar.gz
+
+Sun Oct 3 00:33:57 1993 (jaffer at jacal)
+
+ * MANUAL (bit-count bit-position bit-set*! bit-count*
+ bit-invert!): (from unif.c) are now documented.
+
+ * sys.c (fixconfig): added 3rd argument to distinguish between
+ setjump.h and config.h.
+ * setjump.h config.h: moved IN_SYS stuff from config.h to
+ setjump.h.
+ * config.h (HAVE_CONFIG_H): User config preferences now taken
+ from "scmconfig.h" if HAVE_CONFIG_H is defined.
+ * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS.
+
+Sat Oct 2 00:34:38 1993 rshouman@hermes.chpc.utexas.edu (Radey Shouman)
+
+ * unif.c repl.c: added read and write syntax for uniform vectors.
+ * unif.c (uniform-vector->list list->uniform-vector): created.
+ * time.c (time_in_msec): conditionalized for wide range of CLKTCK
+ values.
+ * config.h (BITSPERDIG POINTERS_MUNGED)
+ * scm.h (PTR2SCM SCM2PTR)
+ * scl.c (DIGSTOOBIG)
+ Ported SCM to Unicos, the Cray operating system.
+
+ From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab)
+ * scl.c (dblprec): set from DBL_DIG, if available.
+
+Fri Oct 1 21:43:58 1993 (jaffer at jacal)
+
+ * unif.c (bit-position): now returns #f when item is not found.
+ Now returns #f when 3rd argument is length of 2nd argument
+ (instead of error).
+
+Fri Sep 24 14:30:47 1993 (jaffer at jacal)
+
+ * sys.c (free_storage): fixed bug where growth_mon was being
+ called after the port cell had been freed. gc_end now also
+ called at end.
+
+Tue Sep 21 23:46:05 1993 (jaffer at jacal)
+
+ * Init.scm scm.c: Restored old command line behaviour (loading all
+ command line arguments) for case when first command line argument
+ does not have leading `-'.
+
+ * sys.c (mode_bits): abstracted from open_file and mksfpt.
+
+ * scm.h (*FPORTP): series of predicates added for operations which
+ only work on some fports.
+
+ * sys.c crs.c: ungetc removed from ptobfuns structure and
+ soft-ports.
+
+Mon Sep 20 23:53:25 1993 (jaffer at jacal)
+
+ * sys.c (make-soft-port): Soft-ports added, allowing Scheme
+ i/o extensions.
+
+Sun Sep 19 22:55:28 1993 (jaffer at jacal)
+
+ * 4c4: released.
+ * Init.scm scm.c scm.1: command line proccessing totally
+ rewritten. Thanks to Scott Schwartz
+ <schwartz@groucho.cs.psu.edu> for help with this.
+
+Mon Sep 13 21:45:52 1993 pegelow@moorea.uni-muenster.de (Ulrich Pegelow)
+
+ * scl.c (add1): finally a way to fool optimizing gcc to not use
+ extra precision registers.
+
+Sun Sep 12 18:46:02 1993 (jaffer at jacal)
+
+ * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS.
+ * config.h: moved flags to top per suggestions from Bryan
+ O'Sullivan (bos@scrg.cs.tcd.ie).
+
+Fri Sep 10 11:42:27 1993 (jaffer at jacal)
+
+ * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values
+ returned by SCM program.
+
+Thu Sep 9 13:09:28 1993 Vincent Manis <manis@cs.ubc.ca>
+
+ * sys.c (stwrite init_types add_final): fixed declarations.
+
+Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README: changed the build and installation instructions to bring
+ them up to date with reality.
+
+Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * Wrote autoconf script to support GNU Autoconf configuration
+ to make scm easier to build.
+
+ * Created Makefile.in; a radical overhaul of Makefile to remove
+ some of the brokenness and allow cross-compilation and use of
+ autoconf.
+
+Sat Sep 4 23:00:49 1993 (jaffer at jacal)
+
+ * 4c3: released.
+ * sys.c (grow_throw): removed use of memset for SPARC machines.
+
+Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * time.c: added SVR4 to the list of LACK_FTIME systems, because
+ most all SVR4 BSD-compatibility stuff is a total mess.
+
+ * config.h: changed definition of STDC_HEADERS so it does the
+ Right Thing on systems which run GCC but don't have header files
+ with prototypes.
+
+ * makefile.unix: added a note for SVR4 users.
+
+Tue Aug 31 18:30:53 1993 (jaffer at jacal)
+
+ * eval.c (m_define): if verbose >= 5 warnings are issued for all
+ top-level redefinitions.
+
+Mon Aug 30 16:24:26 1993 (jaffer at jacal)
+
+ * scm.c sys.c (finals num_finals add_final): Finalization calls
+ now dynamically, incrementally, defined.
+
+Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * 4c2: fixed declaration problems in PTOB with K&R C.
+
+Sun Aug 22 23:02:51 1993 (jaffer at jacal)
+
+ * split.scm: code which directs input, output, and diagnostic
+ output to separate windows (using curses functions defined in
+ crs.c).
+
+Sat Aug 21 16:46:33 1993 (jaffer at jacal)
+
+ * Init.scm (output-port-height): added if not already defined.
+ output-port-width also made conditional.
+
+ * sys.c (tc16_strport): string ports created.
+
+Thu Aug 19 11:37:07 1993 (jaffer at jacal)
+
+ * sys.c (init_types): freecell, floats, and bignums now have SMOB
+ entries. gc_sweep and gc_mark still inline codes for bignums and
+ floats.
+
+ * sys.c repl.c code.doc: Ports now an extensible type.
+ Indirection suggested by Shen <sls@aero.org>.
+
+Mon Aug 16 01:20:26 1993 (jaffer at jacal)
+
+ * crs.c: curses support created.
+
+Sun Aug 15 16:56:36 1993 (jaffer at jacal)
+
+ * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0
+ created.
+
+Fri Jun 25 01:16:31 1993 (jaffer at jacal)
+
+ * QUICKREF: added.
+
+Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently
+ introduced transcript bug.
+
+Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF.
+
+ * Init.scm (defmacro): now copies the results of macro expansion
+ in order to avoid capture of memoized code by macros like:
+ (defmacro f (x) `(list '= ',x ,x)).
+
+Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr)
+
+ * eval.c (map for-each): now check that arguments are lists.
+
+Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (trace untrace): now defmacros which handle (trace) and
+ (untrace) as in Common Lisp.
+
+Wed May 5 01:17:37 1993 Roland Orre <orre@sans.kth.se>
+
+ * all: internal output functions now take SCM ports instead of
+ FILE* in preparation for string-ports.
+
+Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree)
+
+ * makefile.unix (escm.a): created scm "ar" file and used for
+ dbscm.
+
+Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (free_storage): i++ moved out of CELL_* in response to:
+From: john kozak <jkozak@cix.compulink.co.uk>
+Minor bug report: around line 10 of routine "free_storage" you do calls
+to CELL_UP and CELL_DOWN with arguments having side-effects: with the
+PROT386switch defined in config.h these args are evaluated twice...
+
+Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (IM_DEFINE): added. Internal defines are no longer
+ turned into LETRECS.
+
+Wed Apr 7 13:32:53 1993 Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com>
+
+ * scl.c (idbl2str): fix for bug introduced by removing +'s.
+
+Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.c (idbl2str): now prints positivie infinity as +#.# again
+ (instead of #.#).
+
+Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * subr.c (quotient): renamed to lquotient to avoid conflict with
+ HP-UX 9.01.
+
+Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h>
+ * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked.
+
+Mon Mar 15 23:35:32 1993 jhowland@ariel.cs.trinity.edu (Dr. John E. Howland)
+
+ * scl.c (idbl2str iflo2str big2str): leading + eliminated on
+ output and number->string.
+
+Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack.
+
+ * scm.c repl.c (exec): added.
+
+Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): now will print errobjs if they are
+ immediates, symbols, ports, procedures, or numbers.
+
+Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (repl): now gives repl_report() for initialization.
+
+ * Init.scm (defvar): added.
+
+ From: Roland Orre <orre@sans.kth.se>
+ * repl.c (lungetc): no longer calls ungetc. Fixed problem that
+ many systems had with ungetc on unbuffered ports (setbuf(0)).
+
+Thu Mar 4 13:51:12 1993 Stephen Schissler
+
+ * makefile.wcc: Watcom support added.
+
+Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * sys.c scm.h (dynwinds): made a sys_protect.
+
+Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (defmacro macroexpand macroexpand1 macro? gensym):
+ added.
+
+ * repl.c (stdin): setbuf not done for __TURBOC__==1.
+
+ * makefile.bor: now has method to build turtegr.exe.
+
+ * eval.c (ceval): Memoizing macros now can return any legal Scheme
+ expression.
+
+Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (mkbig adjbig): now check for bignum size.
+
+ * Init.scm: reorganized so site-specific information is at the
+ head.
+
+ * repl.c (errno): changed from set-errno now returns value.
+
+ * subr.c (intexpt): now handles bignum exponents.
+
+ From: "David J. Fiander" <davidf@golem.waterloo.on.ca>
+ * time.c makefile.unix subr.c: SCO Unix and XENIX patches.
+
+Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT
+ WITH-ERROR-TO-PORT): added.
+
+ * subr.c (ash): fixed for case (ash 2 40) where INUM arguments
+ make a bignum result.
+
+ * repl.c (lreadr): \ followed by a newline in a string is ignored.
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings.
+
+Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (with-input-from-file with-output-to-file
+ with-error-to-file): now use dynamic-wind.
+
+Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): fixed bug with non-memoizing macro returning an
+ IMP.
+
+Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * (current-error-port with-error-to-file): add.
+
+Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (stat): added.
+
+ From: rnelson@wsuaix.csc.wsu.edu (roger nelson)
+ * dmakefile: support for DICE C on Amiga.
+
+Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (open-file) makes unbuffered if isatty.
+
+ * repl.c (char-ready?) added.
+
+Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logor): changed to LOGIOR to be compatible with common
+ Lisp.
+
+ * eval.c (bodycheck): now checks for empty bodies.
+
+Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (get-universal-time decode-universal-time): now use
+ bignums.
+
+Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (mark_locations): now length argument in terms of
+ STACKITEM. Does both alignments in one pass.
+
+Mon Jan 25 12:13:40 1993 soravi@Athena.MIT.EDU
+
+ * makefile.emx: for OS/2
+
+Sun Jan 24 18:46:32 1993 stevev@miser.uoregon.edu (Steve VanDevender)
+
+ * scl.c (big2str): now faster because it divides by as many 10s as
+ fit in a BIGDIG.
+
+Sat Jan 23 00:23:53 1993 stevev@miser.uoregon.edu (Steve VanDevender):
+
+ * config.h (INUM MAKINUM): shift optimization for TURBOC.
+
+Fri Jan 22 00:46:58 1993 hanche@ams.sunysb.edu (Harald Hanche-Olsen)
+
+ * unif.c (uniform-vector?): added.
+
+Tue Jan 19 00:27:04 1993 stevev@miser.uoregon.edu (Steve VanDevender)
+
+ * subr.c scl.c config.h: bignum bug fixes for MSDOS.
+
+Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (ash lognot intlength logcount bitextract): now handle
+ bignums.
+
+Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (close_port): can now close pipes as well.
+
+ * subr.c (adjbig normbig divide quotient): fixed more divide bugs.
+
+ * subr.c (even? odd?): fixed problem with bignums.
+
+Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (divbigbig): Fixed last divide bug?
+
+Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU
+ regex-0.11. Documentation added to MANUAL.
+
+Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * patchlvl.h (SCMVERSION): moved from config.h.
+
+ * scl.c (product): fixed missing {} bug.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c (lmin lmax) bignum versions.
+
+Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4b0.
+
+ * subr.c: fixed bignum bugs found by jacal.
+
+ * code cleanup.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c (lgcd quotent modulo lremainder): Bignum versions.
+ * subr.c (divbigbig): new version.
+
+Sun Jan 3 00:29:35 1993 stevev@miser.uoregon.edu (Steve VanDevender)
+
+ * Re-port to BorlandC v2.0
+
+ * sys.c (must_realloc): added
+
+ * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of
+ sizeof(long)/sizeof(BIGDIG).
+
+Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * rgx.c: created SCM interface to regex and regexp routines.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c scl.c: Now just one mulbigbig and addbigbig routine.
+
+ from: soravi@Athena.MIT.EDU
+ * README: directions for compiling SCM under OS/2 2.0.
+
+Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (tc7_subr_2x): eliminated. All comparison subrs now
+ rpsubrs.
+
+ * scm.h: Changed SUBR numbers. This improves HP-UX interpretation
+ speed (why?).
+
+ * eval.c (PURE_FUNCTIONAL): removed. Can now be done in
+ initialization code.
+
+ * eval.c (tc7_rpsubr): added type for transitive comparison
+ operators. Suprisingly, this slows down (pi 100 5).
+
+Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logand logor logxor lognot ash logcount integer-length
+ bit-extract): added.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: lots more numeric improvements and code reductions.
+
+Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs.
+
+Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c scl.c: most arithmetic operations will now return
+ bignums.
+
+ * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added.
+
+ * sys.c (object-hash object-unhash): now use bignums.
+
+ * scl.c (big2str istr2int): bignum i/o implemented.
+
+ * unif.c: subr2s were incorrectly initialized as lsubr2s.
+
+Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): added unmemocar calls to error handling when
+ possible.
+
+ * scl.c (idbl2str): added back NAN and infinity support.
+
+ * eval.c (syntax_mem): replaced with individual macros.
+ * eval.c (procedure->syntax procedure->macro
+ procedure->memoizing-macro): All syntactic keywords are now
+ tc7_symbol. User definable macros added.
+ * sys.c: ISYMs no longer in symhash. ISYMs cannot be read.
+ init_isyms merged into init_eval.
+
+Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * makefile.unix (check): now exits with error code.
+
+ * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval.
+
+Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4a13
+
+ * repl.c: longjmps now dowinds() first.
+
+ * setjump.h: now has all setjmp related definitions.
+
+ * Init.scm (trace untrace): use new macro system.
+
+ * eval.c (defined? procedure->macro procedure->memoizing-macro
+ make_synt): macro system added. defined? uses it.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: fixes for several transcendental functions.
+
+Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c sys.c: errjmp replaced with JMPBUF(rootcont).
+
+Sun Nov 15 01:49:00 1992 HEDDEN@esdsdf.dnet.ge.com
+
+ * scl.c (istr2int istr2flo istring2number string2number): new
+ versions.
+
+Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm (load): now prints out actual filename found in mesasge
+ ;done loading ...
+
+Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED
+ becomes WNA error.
+
+ From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+ * scl.c (difference divide): Now are asubrs.
+
+ * Init.scm (*features*): fixed to correspond to SLIB conventions.
+
+Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed
+ to return #f. Tests added to test.scm.
+
+Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (rootcont): sysprotect added.
+
+ From: Vincent Manis <manis@cs.ubc.ca>
+ * scm.h: __cplusplus prototype support.
+
+Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (lookupcar): now checks for UNDEFINED in local bindings
+ becuase LETREC inits to UNDEFINED.
+
+ * sys.c (dynamic-wind): added.
+
+ * config.h eval.c (ceval): CAUTIOUS mode added.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c (ceval): internal defines now transformed to letrecs.
+
+Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (read-line read-line!): created.
+
+Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (lreadparen): now tail-recursive.
+
+ * eval.c (copy-tree eval): added. dummy_cell replaced with a
+ cons(obj,UNDEFINED).
+
+Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (set-errno!): changed to set-errno.
+
+Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (must_free): must_free created. Pointers are set to 0.
+ It detects objects being freed twice.
+
+Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.c (run_scm): Now has INITS and FINALS.
+
+ * scm.c (init_signals ignore_signals unignore_signals
+ restore_signals): siginterrupt() for ultix.
+
+Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * all: put in explicit casts to (unsigned char *) and (long) to
+ satisfy lint.
+
+ * sys.c (gc): all to gc_end was during deferred interrupts,
+ causing problems with verbose=3 and interrupts during GC.
+
+ * config.h(SYSCALLDEF): fixed so that test on errno occurs before
+ ALLOW_INTS (and possible call to user code).
+
+Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (syntax_mem): removed gratuitous cons.
+
+ * eval.c repl.c scm.h: Reduced static string use. Added peephole
+ optimizations for AND and OR.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized
+ so that syntax checks are done only once. Interpreter is now
+ smaller and faster and uses less stack space. Modifications to
+ code are now made under DEFER_INTS as they always should have
+ been.
+
+Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c subr.c scm.h config.h: Started adding bignum code.
+
+Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (restart): added.
+
+ * sys.c (freeall): finished.
+
+ * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to
+ distinguish between non-GCable and GCable symbols.
+
+Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (peek_char lungetc): added workaround for TURBOC 1.0
+ problem with ungetc inside SYSCALLDEF macro.
+
+ * repl.c (iprin1): uses ttyname for #<stream ..> if available.
+
+ * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty.
+
+ * repl.c (isatty?): added.
+
+ * repl.c (verbose): levels bumped up by 1. verbose == 0 means no
+ prompt.
+
+ * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108.
+
+Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2).
+
+ * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply
+ (>= 1 3 2).
+
+ * makefile.unix: tar and shar files now created in subdirectory.
+
+ * config.h time.c: Linux support added.
+
+ * repl.c: Greatly improved VMS interrupt support.
+
+ * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause
+ unnamed lets.y
+
+ * (tc7_lsubr_2n): removed.
+
+Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (bit-position): fixed; I am sure I had done these
+ changes before. Also corrected some error messages.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * scm.h subr.c sys.c (equalp): smobfuns now include equalp.
+
+Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+ * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in
+ BorlandC. This was fixed previously as well.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * unif.c (vector-set-length!): was always typing to tc7_vector.
+
+Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c sys.c (make_vector init_storage resizuve): mallocs and
+ reallocs are now always > 0.
+
+ * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1).
+
+Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (lreadr): now ignores first line of port if begins with "#!"
+
+ * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n.
+
+ * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types
+ rearranged.
+
+Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now
+ support dynamically added smob types. Promises moved to eval.c.
+ Promises and arbiters are now newsmobs.
+
+ * makefile.unix repl.c scl.c (floprint): moved from repl.c to
+ scl.c. The only files which care about -DFLOATS are now scl.c,
+ eval.c, scm.c, and unif.c.
+
+ * sys.c scm.h (init_storage): now uses variable num_protects
+ instead of #define NUM_PROTECTS.
+
+Tue Jul 7 00:00:57 1992 Ulf_Moeller@hh2.maus.de (Ulf Moeller)
+
+ * Init.scm config.h makefile.prj: support for the ATARI-ST with
+ Turbo C added.
+
+Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (make-uniform-vector uniform-vector-set!
+ uniform-vector-ref): added.
+
+Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c code.doc: rearranged tc7 codes and added bvect,
+ ivect, uvect, fvect, dvect, cvect, and cclo.
+
+ * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be
+ tc7_symbol.
+
+Sat Jun 6 22:27:40 1992 campbell@redsox.bsw.com (Larry Campbell)
+
+ * scl.c (divide): divide by 0 and Exact-only divides of non
+ multiples now cause exception in RECKLESS mode.
+
+Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN
+ and made proportional to size of numeric types.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * makefile.ast scm.c Init.scm: minor chages for ATARI ST support.
+
+ * test.scm (test-inexact): created.
+
+Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ * config.h: better wording for heap allocation strategy
+ explanation.
+
+Wed May 20 00:31:18 1992 S.R.Adams@ecs.southampton.ac.uk
+
+ * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid
+ Borland 3.0 bug.
+
+ * sys.c (gc_sweep): missing i-=2; added when splicing out segment.
+
+ * MANUAL time.c (get-universal-time decode-universal-time): half
+ hearted attempt to add these. Needs bignums.
+
+Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_mark): improved tail recursivness for CONSes.
+
+ * repl.c (growth_mon): now prints out the hplims table if
+ verbose>3.
+
+ * sys.c (init_heap_seg): Serious bug in growing hplims fixed.
+ num_heap_segs eliminated; hplims are realloced whenever grown.
+
+Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train)
+
+ * config.h sys.c (alloc_some_heap expmem): expmem captures
+ whether the INIT_HEAP_SIZE allocation was successful. If so,
+ alloc_some_heap uses exponential heap allocation instead of
+ HEAP_SEG_SIZE.
+
+Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments
+ are now freed.
+
+ * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and
+ R3RS functions put into sc2.c.
+
+Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (ignore_interrupts unignore_interrupts): added for
+ system, edt$edit, and popen to use.
+
+ * repl.c (lwrite display newline write_char): Close pipe if EPIPE.
+
+ * repl.c (file_set_position): now errs on ESPIPE.
+
+ * scm.c (SIGPIPE): now ignored (errs come back as EPIPE).
+
+Sat May 9 17:52:36 1992 Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+
+ * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified.
+
+Fri May 8 17:57:22 1992 hugh@ear.mit.edu (Hugh Secker-Walker)
+
+ * Init.scm (last-pair append!): last-pair is faster version.
+ Append! corrected for null first arg. (getenv "HOME") now gets
+ a "/" added if not present.
+
+ * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE.
+
+ * README: setting environment variables corrected.
+
+ * subr.c (length): error message now has arg if not a list.
+
+ * sys.c (open-pipe): now turns off interrupts before forking.
+
+ * scl.c (lsystem): now turns off interrupts before forking.
+
+ * scm.c (ignore_signals): created.
+
+Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in
+ terms of current-input-port and current-output-port. Bug in
+ open-input-pipe and open-output-pipe fixed.
+
+ * sys.c repl.c (current-input-port current-output-port): moved
+ from sys.c to repl.c. set-current-input-port and
+ set-current-output-port added to repl.c.
+
+Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a1.
+
+ * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h.
+
+ * scm.c (alrm_signal int_signal): now save and restore errno so
+ SYSCALL will work correctly across interrupts.
+
+Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a0.
+
+ * repl.c (lread): tok_buf now local to each invocation of read.
+ This makes READ interruptable and reentrant.
+
+ * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created.
+
+ * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c
+
+ * repl.c (lfwrite): now emulated for VMS.
+
+ * repl.c scl.c (num_buf): now local to all routines that use it.
+
+ * time.h: created by moving time functions from repl.c. Read and
+ write functions were moved from sys.c to repl.c.
+
+ * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally
+ rewritten. SIGALRM and SIGINT now execute at interrupt level.
+ Interrupts deferred only for protected code sections, not for
+ reads and writes.
+
+ * sys.c repl.c (SYSCALL): created to reexecute system calls
+ interrupted (EINTR) by SIGALRM and SIGINT.
+
+ * sys.c scl.c (flo0): 0.0 is now always flo0.
+
+ * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This
+ required shadowing putc, fputs, fwrite, and getc with lputc,
+ lputs, lfwrite, and lgetc.
+
+Sun Apr 5 00:27:33 1992 HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+
+ * scl.c (eqp lessp greaterp lesseqp greatereqp):
+ Comparisons with inexact numbers was not being performed
+ correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was
+ missing was a line x=y; in the inexact comparison sections of
+ lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I
+ modified these routines and eqp() to allow for mixed arithmetic
+ types.
+
+Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and
+ tc16_bigneg. SMOBS reordered. tc16_record added.
+
+ * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter):
+ added. tc16_arbiter added.
+
+Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (TEMPTEMPLATE): created in config.h.
+
+ * scm.h: removed long aliases for C versions of Scheme functions.
+
+ * sys.c eval.c scm.h: (delay force makprom): added. Also added
+ tc16_promise data type.
+
+ * Init.scm (trace untrace): added autoloads and read macros.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * sys.c (template): correct template for VMS.
+
+Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h Init.scm (open-file open-pipe): created and
+ expressed other open functions in terms of. Bracketed all i/o
+ system calls with DEFER and ALLOW _SIGINTS.
+
+Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c MANUAL (#.): read macro syntax added. Balanced comments
+ also documented.
+
+Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (iprin1): changed printed representation for unreadable
+ objects from #[...] to #<...>.
+
+ From: brh@aquila.ahse.cdc.com (brian r hanson x6009):
+ * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on
+ nosve.
+
+Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c13
+
+ * code.doc: corrected some minor inconsistencies and added a
+ section "To add a package of new procedures to scm".
+
+Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm: now loads <program-name>_INIT_PATH when <program-name>
+ is not "SCM".
+
+ * config.h (PTR_LT): (x < y) => ((x) < (y))
+
+Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c12.
+
+ * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM
+ type.
+
+Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added
+ DEFINED? to ceval conditional on SYNTAX_EXTENSIONS.
+
+ From: Andrew Wilcox <andrew@astro.psu.edu>
+ * makefile.unix scm.c (main init_scm display_banner init_signals
+ restore_signals run_scm): RTL support.
+
+Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c (make-string): now checks for ARG1 >= 0.
+
+Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+ * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL,
+ jcal or jacal.
+
+ * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported.
+
+ * gc_mark gc: no longer assume sizeof(short) == 2.
+
+ * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8.
+
+ From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com
+ * scl.c config.h repl.c: partial port to Control Data NOS/VE.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * repl.c Init.scm makefile.ast: Port to Atari-ST
+
+ * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict
+ with Gnu CC.
+
+Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (delete-file rename-file): added.
+
+ * sys.c (chdir): now returns #f instead of error.
+
+ * Init.scm: Calls to PROVIDED? inlined so no longer dependent on
+ SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported.
+ Support for slib1b3 added.
+
+ * sys.c (alloc_some_heap): fixed bugs. One fix from
+ bowles@is.s.u-tokyo.ac.jp.
+
+ * eval.c (ceval): fixed bug with internal (define foo bar) where
+ bar is a global. Put badfun2: back in for better error reporting.
+
+ * patchlvl.h (PATCHLEVEL): 11
+
+Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.c (INITS): comments added.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * VMSGCC.COM VMSMAKE.COM: now take arguments.
+
+ From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+ * makefile.aztec repl.c: Aztec C (makefile) port.
+
+Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc init_storage stack_size): stack_size now of type
+ sizet. init_storage no longer uses it. gc() now uses it instead
+ of pointer to local. This fixes bug with gcc -O.
+
+ * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above
+ fix.
+
+Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (real-part): added.
+
+Wed Jan 15 13:06:39 1992 "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+
+ * scl.c repl.c scm.c config.c: Port for AMIGA
+
+ * scm.h (REALP): fixed for SINGLES not defined.
+
+Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 8 released.
+
+ * README: added hints for EDITING SCHEME CODE.
+
+ * repl.c (SIGRETTYPE): now int for __TURBOC__.
+
+ * makefile.tur makefile.djg: created.
+
+ * config.h: DJGPP (__GO32__) support added.
+
+ * scm.h (memv): definition added.
+
+Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c makefile.* (main): INITS added.
+
+ * scl.c: fixed ASSERT statements with mismatched ARGn and
+ arguments.
+
+Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train)
+
+ * sys.c (cons cons2 cons2r): added fix for gcc -O bug.
+
+ * repl.c (LACK_FTIME LACK_TIMES): more messing with these.
+
+ * sys.c config.o (HAVE_PIPE): created.
+
+ * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__.
+ Needed for DJGCC.
+
+ * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly
+ rather than STDC_INCLUDES.
+
+ * makefile.unix (subr.o): explicit compilation line added.
+
+ * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries.
+
+Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (apply): added check for number of args to closures.
+
+Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 7
+
+ * sys.c (chdir): THINK_C doesn't support;
+
+ * repl.c: SVR2 needs <time.h> instead of <sys/time.h>
+
+ * repl.c: SVR2 needs LACK_FTIME
+
+ * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME.
+
+Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * sys.c (intern sysintern): made strings and hash unsigned. Fixed
+ bug with characters > 128 in symbols.
+
+ From: boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza)
+ * scl.c (eqv? memv assv): created if FLOATS is #defined.
+
+Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 4
+
+ * sys.c (gc_sweep): usaage of pclose() now conditional on unix.
+
+ * MANUAL (chdir): documented.
+
+ From: T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>:
+
+ * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h>
+ to get the link-time attributes for the errno variable to match
+ those the VMS C run-time library expects (it makes errno a
+ preprocessor define so that the variable that the compiler sees
+ has a special form that the assember then interprets), so if it is
+ VMS and __GNUC__ is defined <errno.h> needs included.
+
+ * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to
+ setjump and longjump. The VMS linker is case-indifferent. VMS GNU
+ C mangles variable names that have upper case letters in them to
+ preserve their uniqueness.
+
+ * sys.c (iprint iprin1): Now inline putc loops instead of calls to
+ fwrite for VMS. The VMS `fwrite' has been enhanced to work with
+ VMS's Record Management Sevice, RMS. Part of this enhancement is
+ to treat each call to `fwrite' as producing a seperate record.
+ This works fine if you are writing to a stream_LF file or an
+ actual terminal screen, but if you are writing to a file that has
+ implied carriage control (such as a batch log file, or a mailbox
+ used for subprocess communication), which is a more common file
+ organization for RMS, each call to `fwrite' has a newline appended
+ to it. This causes much of the output to be incorrectly split
+ across lines.
+
+ * vmsgcc.com: created.
+
+Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 3 released.
+
+ * Init.scm (rev2-procedures): all now supported.
+
+ * Init.scm sys.c MANUAL (flush): flush changed to force-output to
+ be compatible with Common Lisp.
+
+ * sys.c (chdir): added.
+
+Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 2
+
+ * repl.c (set-errno! perror): added.
+
+ * sys.c (gc): FLUSH_REGISTER_WINDOWS call added.
+
+ * sys.c (open-input-pipe open-output-pipe close-pipe): added.
+
+Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 1
+
+ * sys.c (flush): added.
+
+ * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60.
+
+ From: Yasuaki Honda, honda@csl.SONY.co.jp,
+ * README Init.scm subr.c scm.c repl.c scl.c: support for
+ Macintosh running Think C.
+
+Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (str2flo): fixed parsing of -1-i.
+
+ * subr.c (equal): Now correct for inexacts. Need to do eqv.
+
+ * scm.h (REALPART): fixed pixel C compiler bug with doubles inside
+ `?' conditionals.
+
+ * scl.c (zerop): now checks imaginary half of complex number.
+
+ From: jjc@jclark.com
+ * repl.c (repl_driver): now checks that s_response is non-NULL
+ before INTERNing.
+
+Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * version scm3c0
+
+ * documentation: changed revised^3.99 to revised^4.
+
+ * example.scm: created from Scheme^4 spec.
+
+ * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float
+ optimizations.
+
+ * Init.scm (ed): defined.
+
+ * repl.c (def_err_response): UNDEFINED objects don't print out.
+
+Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (vms-debug): now returns UNSPECIFIED.
+
+ * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT.
+
+ * repl.c (err_ctrl_c):now clears sig_pending.
+
+Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: removed #ifdef sparc #define STDC_HEADERS
+
+ * makefile.bor: added extra '\' to filepath.
+
+ * repl.c (everr): fixed bug with ARGx.
+
+ * repl.c (errmsgs def_err_response): cleaned up error messages.
+
+Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * released scm3b7
+
+Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 6
+
+ * sys.c (idbl2str): tests for Not-a-Number and Infinity added.
+
+ * repl.c scm.h: response system rewritten and integrated with
+ error system.
+
+ * scl.c (/): now returns inexacts if integer arguments do not
+ divide evenly.
+
+Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * makefile.unix: can now make float (scm) and integer-only (escm)
+ versions in same directory.
+
+ * repl.c (*sigint-response* *arithmetic-response* restart-repl):
+ responses for signals added.
+
+ * scl.c (lmin lmax sum difference product divide expt exp log):
+ now take mixed types. expt available in non-FLOATS compilation.
+
+ * repl.c (get-decoded-time): added. Includes and time functions
+ reorganized.
+
+ * sys.c (object-hash object-unhash): added.
+
+Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c Init.scm (*features*): moved constant features into
+ Init.scm. Moved tests for numeric features to slib/require.scm.
+
+ * release scm3b1.
+
+ * config.h (ANSI_INCLUDES): redid include files.
+
+ * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c.
+
+Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * release scm3a13.
+
+ * patchlvl.h (PATCHLEVEL): 13
+
+ * Init.scm: "vicinity.scm" changed to "require.scm"
+
+Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: test of redefining built-in symbol and extra ')'
+ removed.
+
+ * scm.doc makefile.unix: scm.doc created from scm.1 in
+ makefile.unix.
+
+ * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put
+ in from comp.sources.reviewed in order to let VMS have full
+ continuations. VMSBUILD.COM is a compile script.
+
+Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): removed; not supported by MSC (although could be
+ written).
+
+ * scm.h config.h (size_t): moved to config.h.
+
+ * sys.c (f_getc): -> lgetc for vax, getc otherwise.
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): created.
+
+ * repl.c(internal-time-units-per-second get=internal-run-time):
+ created
+
+ * repl.c: created from scm.c (shuffled around lots of functions).
+
+Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c config.h (char-code-limit most-positive-fixnum
+ most-negative-fixnum): created.
+
+Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (software-type); created.
+
+ * scm.c config.h (terms, list-file, library-vicinity,
+ program-vicinity, user-vicinity, make-vicinity, sub-vicinity):
+ moved to Init.scm and library.
+
+ * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH.
+
+ * Init.scm: created
+
+Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * all: changed declarations to size_t where appropriate. scm.h
+ test preprocessor flag _SIZE_T to determine if already declared.
+ size_t should greatly enhance portability to Macintosh and other
+ machines.
+
+Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (tmpnam): support for mktemp added.
+
+Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train)
+
+ * scm.c (implementation-vicinity): added. (program-vicinity) now
+ returns undefined if called not within a load.
+
+ * sys.c (call-with-io-file): removed.
+
+ * scm.c (tmpnam): added.
+
+ * scm.c config.h (tmporary-vicinity): removed.
+
+Sun Sep 15 22:21:30 1991 bevan@cs.man.ac.uk
+
+ * subr.c scm.h (remainder): renamed to lremainder to avoid
+ conflict with math.h on SunOS4.1.
+
+Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (program-arguments load): program-arguments created.
+
+ * scm.c (getenv): added getenv and used for program-vicinity and
+ library-vicinity.
+
+ * scm.c (program-vicinity): fixed if load_name is NULL.
+
+ * scl.c config.h (substring-move-left! substring-move-right!):
+ added under STR_EXTENSIONS flag.
+
+Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * Sending scm3a to comp.sources.reviewed
+
+ * scm.c (main): prints out feature list at startup.
+
+ * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for
+ floats.
+
+ * scl.c (sum difference divide product): moved to scl.c and
+ now work for floats.
+
+ * all: all masks with low bits explicity cast to (int).
+
+Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo
+ iflo2str idbl2str): number I/O and conversion to strings rewritten.
+
+ * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from
+ Craig Lawson).
+
+ * added QuickC support from Craig Lawson.
+
+Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: #ifdef pyr added.
+
+ * scm.c MANUAL: vicinity functions added.
+
+Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c sys.c: float functions added.
+
+ * Documentation reorganized according to comp.sources.reviewed
+ guidelines.
+
+ * sys.c config.h (open_input_file open_output_file open_rw_file):
+ file mode string moved to defines in config.h
+
+Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (EBCDIC ASCII) moved to config.h
+
+ * subr.c config.h (BADIVSGNS) moved to config.h
+
+ * scm.h config.h (SRS) moved to config.h
+
+Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all: started adding comp.sources.reviewed corrections and
+ suggestions.
+
+ * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner.
+
+ * subr.c sys.c: read_integer removed. istring2number created.
+ lread and string2number now both use istring2number.
+
+Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * VERSION scm2e sent to comp.sources.reviewed
+
+ * public.lic: renamed COPYING.
+
+ * scm.c (gc_status): gc_status renamed prolixity. Now returns old
+ value of verbose. Can take 0 arguments.
+
+ * sys.c (lreadr): added #| common lisp style |# balanced comments.
+
+ * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to
+ become OP**PORTP.
+
+ * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of
+ port cells.
+
+Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (stack_start_ptr, repl_driver, main, err functions):
+ exits removed from all err functions. all escapes through
+ repl_driver.
+
+ * scm.c README (verbose): Now has graded verbosity.
+
+ * scm.c README (quit): Now takes optional argument which is return
+ value.
+
+Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to
+ create IXSYMs (immediate extension syms) to allow more than 15
+ special forms. ILOCs now work with up to 32767 in one environment
+ frame. Dispatch is slightly faster for ILOCs in function position.
+ ICHRs can be up to 24 bits.
+
+Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR
+ for some datatypes.
+
+Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patch1 MESSAGE SENT.
+
+ From: jclark@bugs.specialix.co.uk.jjc
+ * sys.c (lreadr): removed
+ order evaluation bug when growing tok_buf.
+
+Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm2d RELEASED
+
+ * sys.c (closure) no longer calls ilength (ECONS problem). Added
+ ASSERT before call to closure in eval.
+
+Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (error): created.
+
+Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * utils.scm: created.
+
+ * makefile (name8s): code from dmason works in makefile.
+
+ * eval.c (evalcar): fixed errobj on (else 3 4) error.
+ Inlined function application in (cond ((foo => fun))).
+
+ * sys.c (lprin1): change looped putcs to fwrite.
+
+Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (lreadr): fixed assert for "eof in string".
+
+ * subr.c (lgcd): changed to work with borland C.
+
+ * eval.c (eval): added checks to LAMBDA and LET.
+
+ * eval.c (apply): now checks for null arg1 in lsubr.
+
+Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph)
+
+ * config.h scm.h (SCMPTR): created to correct address arithmetic
+ on stack bounds under Borland C++. Borland C++ now runs scm2c.
+
+Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (open_io_file, cw_io_file, file_position, file_set_pos,
+ read_to_str) created (IO_EXTENSIONS)
+
+ * config.h (IO_EXTENSIONS): defined
+
+ * sys.c scm.c: lprin1f changed to iprin1
+
+Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to
+ for(i = alen;0 < --i;).
+ This fixed b_pos and v_pos mapping to the same symbol.
+
+Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu)
+
+ * released scm2b
+
+Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all files: eliminated types tc7_subr_2n and tc7_subr_2xn.
+ Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls
+ can be checked for number of arguments.
+
+Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc: cleaned up.
+
+Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (ceval): fixed nasty tail recursion bug at carloop:.
+
+ * scm.c (everr): still fixing error reporting.
+
+ * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side
+ effect special forms and functions.
+
+ * subr.c (substring): now allows first index to be equal to length
+ of string
+
+ * sys.c (lprin1f): dispatches on TYP16 of smobs.
+
+ * scm.h: fixed typo in unused function defs.
+
+Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu)
+
+ * scm2a released: too many changes to record. See code.doc.
+
+Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.h: types reformatted (TYP6 -> TYP7).
+
+ * eval.c (ceval): Now dispatch directly on ISYMs in ceval.
+
+Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * sys.c: #include <malloc.h> not done for VMS
+
+Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.c scl.c: added unsigned declarations to some char *
+ definitions in order to fix characters having negative codes.
+
+ * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to
+ long so that their calls don't have to. Changing MAKICHR fixed
+ problem in scl.c (string2list) on IBMPC.
+
+ * subr.c (quotient): support for `/' reintroduced; required by
+ r3.99rs but not IEEE.
+
+ * subr.c (char functions): added isascii tests for
+ char-alphabetic, char-numeric?, char-whitespace?,
+ char-upper-case?, and char-lower-case?. Added test against
+ char_code_limit to int2char.
+
+ * subr.c (s_char_alphap): is subr_1 not lsubr.
+
+ * test.scm: added tests for char-alphabetic, char-numeric?,
+ char-whitespace?, char-upper-case?, and char-lower-case?.
+
+ * sys.c: most `return;'s eliminated to reduce warning messages.
+ Substituted breaks and reordered switch and if clauses.
+
+Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm1-2: released.
+
+ * sys.c (read-char peek-char) added code for EOF.
+
+ * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O
+ tests added.
+
+ * sys.c (I/O functions) now check for input and output ports
+ rather than just ports.
+
+ * sys.c (lprin1f): occurences of stdout changed to f. Newlines
+ after printing port removed.
+
+Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * subr.c (quotient): support for `/' removed; not required.
+
+ * scm.c (wta): message for OUTOFRANGE fixed.
+
+Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * eval.c (apply): added checks for number of arguments.
+
+ * scm.h (CHECK_SIGINT): checks for blocked SIGINT.
+
+ * sys.c (lprin1): added blocking and testing for SIGINT so that
+ output won't hang on VMS.
+
+ * scm.c (repl): added fflush call.
+
+ * scm.c (err_head, wta): added fflush calls to error routines so
+ that error message come out in proper order.
+
diff --git a/Iedline.scm b/Iedline.scm
new file mode 100644
index 0000000..cbeb265
--- /dev/null
+++ b/Iedline.scm
@@ -0,0 +1,103 @@
+;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;; "Iedline.scm" Scheme interface to readline library
+;; Author: Radey Shouman
+
+;; Change both current-input-port and current-output-port to
+;; allow line editing of input.
+;; All output goes through a soft port in order to detect prompt
+;; lines, i.e. lines unterminated by a newline.
+
+(define (make-edited-line-port)
+ (let ((prompt "")
+ (outp (default-output-port))
+ (inp (default-input-port))
+ (strp (call-with-input-string "" identity)))
+ (make-soft-port
+ (vector (lambda (c)
+ (write-char c outp))
+ (lambda (s)
+ (display s outp)
+ (or (zero? (string-length s))
+ (eq? #\newline (string-ref s (- (string-length s) 1)))
+ (begin
+ (set! prompt (string-append "\r" s))
+ (force-output outp))))
+ (lambda ()
+ (force-output outp))
+ (lambda ()
+ (let tail ((c (read-char strp)))
+ (if (char? c) c
+ (let ((str (read-edited-line prompt)))
+ (if (string? str)
+ (let ((n (string-length str)))
+ (add-history str)
+ (vector-set-length! str (+ 1 n))
+ (string-set! str n #\newline)
+ (set! strp (call-with-input-string
+ str identity))
+ (tail (read-char strp)))
+ str)))))
+ #f)
+ OPEN_BOTH)))
+
+(define line-editing
+ (let ((edit-port #f)
+ (oiport #f)
+ (ooport #f))
+ (lambda arg
+ (define past edit-port)
+ (cond ((null? arg))
+ ((and (car arg) (not edit-port))
+ (set! edit-port (make-edited-line-port))
+ (set! oiport (set-current-input-port edit-port))
+ (set! ooport (set-current-output-port edit-port)))
+ (edit-port
+ (set-current-input-port oiport)
+ (set-current-output-port ooport)
+ (set! edit-port #f)))
+ past)))
+
+(and
+ (if (provided? 'unix) (isatty? (current-input-port)) #t)
+ (eq? (current-input-port) (default-input-port))
+ (not (getenv "EMACS"))
+ (line-editing #t))
diff --git a/Init.scm b/Init.scm
new file mode 100644
index 0000000..758c407
--- /dev/null
+++ b/Init.scm
@@ -0,0 +1,854 @@
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Init.scm", Scheme initialization code for SCM.
+;;; Author: Aubrey Jaffer.
+
+(define (scheme-implementation-type) 'SCM)
+(define (scheme-implementation-version) "4e6")
+
+;;; Temporary hack for compatability with older versions.
+(define software-type
+ (cond ((eq? 'msdos (software-type))
+ (lambda () 'ms-dos))
+ (else software-type)))
+
+;;; This definition of PROGRAM-VICINITY is a copy of the definition in
+;;; SLIB/require.scm. It is used here to bootstrap
+;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY.
+
+(define program-vicinity
+ (let ((*vicinity-suffix*
+ (case (software-type)
+ ((AMIGA) '(#\: #\/))
+ ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/))
+ ((MACOS THINKC) '(#\:))
+ ((NOSVE) '(#\: #\.))
+ ((UNIX COHERENT) '(#\/))
+ ((VMS) '(#\: #\])))))
+ (lambda ()
+ (let loop ((i (- (string-length *load-pathname*) 1)))
+ (cond ((negative? i) "")
+ ((memv (string-ref *load-pathname* i) *vicinity-suffix*)
+ (substring *load-pathname* 0 (+ i 1)))
+ (else (loop (- i 1))))))))
+
+(define in-vicinity string-append)
+
+;;; This is the vicinity where this file resides.
+(define implementation-vicinity
+ (let ((vic (program-vicinity)))
+ (lambda () vic)))
+
+;;; (library-vicinity) should be defined to be the pathname of the
+;;; directory where files of Scheme library functions reside.
+
+;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use
+;;; (implementation-vicinity) as (library-vicinity). "require.scm",
+;;; the first file loaded from (library-vicinity), can redirect it.
+
+(define library-vicinity
+ (let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
+ (if library-path (lambda () library-path)
+ implementation-vicinity)))
+
+;;; Here for backward compatability
+(define scheme-file-suffix
+ (case (software-type)
+ ((NOSVE) (lambda () "_scm"))
+ (else (lambda () ".scm"))))
+
+(set! *features*
+ (append '(getenv tmpnam abort transcript with-file
+ ieee-p1178 rev4-report rev4-optional-procedures
+ hash object-hash delay eval dynamic-wind
+ multiarg-apply multiarg/and- logical defmacro
+ string-port source current-time)
+ *features*))
+
+(define slib:exit quit)
+(define (exec-self)
+ (require 'i/o-extensions)
+ (execv (execpath) (program-arguments)))
+
+(define (terms)
+ (list-file (in-vicinity (implementation-vicinity) "COPYING")))
+
+(define (list-file file)
+ (call-with-input-file file
+ (lambda (inport)
+ (do ((c (read-char inport) (read-char inport)))
+ ((eof-object? c))
+ (write-char c)))))
+
+(define (read:eval-feature exp)
+ (cond ((symbol? exp)
+ (or (memq exp *features*) (eq? exp (software-type))))
+ ((and (pair? exp) (list? exp))
+ (case (car exp)
+ ((not) (not (read:eval-feature (cadr exp))))
+ ((or) (if (null? (cdr exp)) #f
+ (or (read:eval-feature (cadr exp))
+ (read:eval-feature (cons 'or (cddr exp))))))
+ ((and) (if (null? (cdr exp)) #t
+ (and (read:eval-feature (cadr exp))
+ (read:eval-feature (cons 'and (cddr exp))))))
+ (else (error "read:sharp+ invalid expression " exp))))))
+
+(define (read:array digit port)
+ (define chr0 (char->integer #\0))
+ (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
+ (if (char-numeric? (peek-char port))
+ (readnum (+ (* 10 val)
+ (- (char->integer (read-char port)) chr0)))
+ val)))
+ (prot (if (eq? #\( (peek-char port))
+ '()
+ (let ((c (read-char port)))
+ (case c ((#\b) #t)
+ ((#\a) #\a)
+ ((#\u) 1)
+ ((#\e) -1)
+ ((#\s) 1.0)
+ ((#\i) 1/3)
+ ((#\c) 0+i)
+ (else (error "read:array unknown option " c)))))))
+ (if (eq? (peek-char port) #\()
+ (list->uniform-array rank prot (read port))
+ (error "read:array list not found"))))
+
+(define (read:uniform-vector proto port)
+ (if (eq? #\( (peek-char port))
+ (list->uniform-array 1 proto (read port))
+ (error "read:uniform-vector list not found")))
+
+(define (read:sharp c port)
+ (define (barf)
+ (error "unknown # object" c))
+ (case c ((#\') (read port))
+ ((#\+) (if (read:eval-feature (read port))
+ (read port)
+ (begin (read port) (if #f #f))))
+ ((#\-) (if (not (read:eval-feature (read port)))
+ (read port)
+ (begin (read port) (if #f #f))))
+ ((#\b) (read:uniform-vector #t port))
+ ((#\a) (read:uniform-vector #\a port))
+ ((#\u) (read:uniform-vector 1 port))
+ ((#\e) (read:uniform-vector -1 port))
+ ((#\s) (read:uniform-vector 1.0 port))
+ ((#\i) (read:uniform-vector 1/3 port))
+ ((#\c) (read:uniform-vector 0+i port))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (read:array c port))
+ ((#\!) (if (= 1 (line-number))
+ (let skip () (if (eq? #\newline (peek-char port))
+ (if #f #f)
+ (begin (read-char port) (skip))))
+ (barf)))
+ (else (barf))))
+
+(define type 'type) ;for /bin/sh hack.
+
+;;;; Here are some Revised^2 Scheme functions:
+(define 1+
+ (let ((+ +))
+ (lambda (n) (+ n 1))))
+(define -1+
+ (let ((+ +))
+ (lambda (n) (+ n -1))))
+(define 1- -1+)
+(define <? <)
+(define <=? <=)
+(define =? =)
+(define >? >)
+(define >=? >=)
+(define t #t)
+(define nil #f)
+(define sequence begin)
+
+(set! apply
+ (let ((apply:nconc-to-last apply:nconc-to-last)
+ (@apply @apply))
+ (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
+(define call-with-current-continuation
+ (let ((@call-with-current-continuation @call-with-current-continuation))
+ (lambda (proc) (@call-with-current-continuation proc))))
+
+;;; VMS does something strange when output is sent to both
+;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
+(case (software-type) ((VMS) (set-current-error-port (current-output-port))))
+
+;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
+;;; mode to open files in. MS-DOS does carraige return - newline
+;;; translation if not opened in `b' mode.
+
+(define OPEN_READ (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "rb")
+ (else "r")))
+(define OPEN_WRITE (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "wb")
+ (else "w")))
+(define OPEN_BOTH (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "r+b")
+ (else "r+")))
+(define (_IONBF mode) (string-append mode "0"))
+
+(define could-not-open #f)
+
+(define (open-input-file str)
+ (or (open-file str OPEN_READ)
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "OPEN-INPUT-FILE couldn't open file " str)))
+(define (open-output-file str)
+ (or (open-file str OPEN_WRITE)
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "OPEN-OUTPUT-FILE couldn't open file " str)))
+(define (open-io-file str) (open-file str OPEN_BOTH))
+
+(define close-input-port close-port)
+(define close-output-port close-port)
+(define close-io-port close-port)
+
+(define (call-with-input-file str proc)
+ (let* ((file (open-input-file str))
+ (ans (proc file)))
+ (close-input-port file)
+ ans))
+
+(define (call-with-output-file str proc)
+ (let* ((file (open-output-file str))
+ (ans (proc file)))
+ (close-output-port file)
+ ans))
+
+(define (with-input-from-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-output-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-error-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-input-from-file file thunk)
+ (let* ((nport (open-input-file file))
+ (ans (with-input-from-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-output-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-output-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-error-to-file file thunk)
+ (let* ((nport (open-output-file file))
+ (ans (with-error-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(if (not (defined? force-output))
+ (define (force-output . a) #f))
+
+(define (error . args)
+ (define cep (current-error-port))
+ (perror "ERROR")
+ (errno 0)
+ (display "ERROR: " cep)
+ (if (not (null? args))
+ (begin (display (car args) cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep))
+ (cdr args))))
+ (newline cep)
+ (force-output cep)
+ (abort))
+
+(define set-errno errno)
+(define exit quit)
+
+(define (file-exists? str)
+ (let ((port (open-file str OPEN_READ)))
+ (if port (begin (close-port port) #t)
+ #f)))
+
+(define difftime -)
+(define offset-time +)
+
+(if (not (memq 'ed *features*))
+ (begin
+ (define (ed . args)
+ (system (apply string-append
+ (or (getenv "EDITOR") "ed")
+ (map (lambda (s) (string-append " " s)) args))))
+ (set! *features* (cons 'ed *features*))))
+
+(if (not (defined? output-port-width))
+ (define (output-port-width . arg) 80))
+
+(if (not (defined? output-port-height))
+ (define (output-port-height . arg) 24))
+
+(if (not (defined? last-pair))
+ (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
+
+(define (has-suffix? str suffix)
+ (let ((sufl (string-length suffix))
+ (sl (string-length str)))
+ (and (> sl sufl)
+ (string=? (substring str (- sl sufl) sl) suffix))))
+
+(define (identity x) x)
+(define slib:error error)
+(define slib:tab #\tab)
+(define slib:form-feed #\page)
+(define slib:eval eval)
+
+;;; Load.
+(define load:indent 0)
+(define (load:pre file)
+ (define cep (current-error-port))
+ (cond ((> (verbose) 1)
+ (display
+ (string-append ";" (make-string load:indent #\ ) "loading " file)
+ cep)
+ (set! load:indent (modulo (+ 2 load:indent) 16))
+ (newline cep)))
+ (force-output cep))
+
+(define (load:post filesuf)
+ (define cep (current-error-port))
+ (errno 0)
+ (cond ((> (verbose) 1)
+ (set! load:indent (modulo (+ -2 load:indent) 16))
+ (display (string-append ";" (make-string load:indent #\ )
+ "done loading " filesuf)
+ cep)
+ (newline cep)
+ (force-output cep))))
+
+(define (scm:load file . libs)
+ (define filesuf file)
+ (define hss (has-suffix? file (scheme-file-suffix)))
+ (load:pre file)
+ (or (and (defined? link:link) (not hss)
+ (or (apply link:link file libs)
+ (and link:able-suffix
+ (let ((fs (string-append file link:able-suffix)))
+ (cond ((not (file-exists? fs)) #f)
+ ((apply link:link fs libs) (set! filesuf fs) #t)
+ (else #f))))))
+ (and (null? libs) (try-load file))
+ ;;HERE is where the suffix gets specified
+ (and (not hss)
+ (begin (errno 0) ; clean up error from TRY-LOAD above
+ (set! filesuf (string-append file (scheme-file-suffix)))
+ (try-load filesuf)))
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (let () (set! load:indent 0)
+ (error "LOAD couldn't find file " file)))
+ (load:post filesuf))
+(define load scm:load)
+(define slib:load load)
+
+(define (scm:load-source file)
+ (define sfs (scheme-file-suffix))
+ (define filesuf file)
+ (load:pre file)
+ (or (and (or (try-load file)
+ ;;HERE is where the suffix gets specified
+ (and (not (has-suffix? file sfs))
+ (begin (set! filesuf (string-append file sfs))
+ (try-load filesuf)))))
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "LOAD couldn't find file " file))
+ (load:post filesuf))
+(define slib:load-source scm:load-source)
+
+(load (in-vicinity (library-vicinity) "require"))
+
+;;; DO NOT MOVE! This has to be done after "require.scm" is loaded.
+(define slib:load-source scm:load-source)
+(define slib:load scm:load)
+
+(cond ((or (defined? dyn:link)
+ (defined? vms:dynamic-link-call)
+ (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
+ (load (in-vicinity (implementation-vicinity) "Link"))))
+
+(cond ((defined? link:link)
+ (define (slib:load-compiled . args)
+ (or (apply link:link args)
+ (error "Couldn't link files " args)))
+ (provide 'compiled)))
+
+(define (string-upcase str) (string-upcase! (string-copy str)))
+(define (string-downcase str) (string-downcase! (string-copy str)))
+(define (string-capitalize str) (string-capitalize! (string-copy str)))
+
+(define logical:logand logand)
+(define logical:logior logior)
+(define logical:logxor logxor)
+(define logical:lognot lognot)
+(define logical:ash ash)
+(define logical:logcount logcount)
+(define logical:integer-length integer-length)
+(define logical:bit-extract bit-extract)
+(define logical:integer-expt integer-expt)
+
+(define (logical:ipow-by-squaring x k acc proc)
+ (cond ((zero? k) acc)
+ ((= 1 k) (proc acc x))
+ (else (logical:ipow-by-squaring (proc x x)
+ (quotient k 2)
+ (if (even? k) acc (proc acc x))
+ proc))))
+
+;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
+(define *defmacros* '())
+(define (defmacro? m) (and (assq m *defmacros*) #t))
+
+(define defmacro:transformer
+ (lambda (f)
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (copy-tree (apply f (cdr exp)))))))
+
+(define defmacro
+ (let ((defmacro-transformer
+ (lambda (name parms . body)
+ `(define ,name
+ (let ((transformer (lambda ,parms ,@body)))
+ (set! *defmacros* (acons ',name transformer *defmacros*))
+ (defmacro:transformer transformer))))))
+ (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
+ (defmacro:transformer defmacro-transformer)))
+
+(define (macroexpand-1 e)
+ (if (pair? e) (let ((a (car e)))
+ (cond ((symbol? a) (set! a (assq a *defmacros*))
+ (if a (apply (cdr a) (cdr e)) e))
+ (else e)))
+ e))
+
+(define (macroexpand e)
+ (if (pair? e) (let ((a (car e)))
+ (cond ((symbol? a)
+ (set! a (assq a *defmacros*))
+ (if a (macroexpand (apply (cdr a) (cdr e))) e))
+ (else e)))
+ e))
+
+(define gentemp
+ (let ((*gensym-counter* -1))
+ (lambda ()
+ (set! *gensym-counter* (+ *gensym-counter* 1))
+ (string->symbol
+ (string-append "scm:G" (number->string *gensym-counter*))))))
+
+(define defmacro:eval slib:eval)
+(define defmacro:load load)
+
+(define (slib:eval-load <filename> evl)
+ (if (not (file-exists? <filename>))
+ (set! <filename> (string-append <filename> (scheme-file-suffix))))
+ (call-with-input-file <filename>
+ (lambda (port)
+ (let ((old-load-pathname *load-pathname*))
+ (set! *load-pathname* <filename>)
+ (do ((o (read port) (read port)))
+ ((eof-object? o))
+ (evl o))
+ (set! *load-pathname* old-load-pathname)))))
+
+(define (print . args)
+ (define result #f)
+ (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
+ (newline)
+ result)
+
+;;; Autoloads for SLIB procedures.
+
+(define (tracef . args) (require 'trace) (apply tracef args))
+(define (trace:tracef . args) (require 'trace) (apply trace:tracef args))
+(define (trace-all . args) (require 'debug) (apply trace-all args))
+(define (pretty-print . args) (require 'pretty-print)
+ (apply pretty-print args))
+
+;;; Macros.
+
+;;; Trace gets redefmacroed when tracef autoloads.
+(defmacro trace x
+ (if (null? x) '()
+ `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x))))
+(defmacro break x
+ (if (null? x) '()
+ `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) x))))
+
+(defmacro defvar (var val)
+ `(if (not (defined? ,var)) (define ,var ,val)))
+
+(cond
+ ((defined? stack-trace)
+
+ #+breakpoint-error;; remove this line to enable breakpointing on errors
+ (define (error . args)
+ (define cep (current-error-port))
+ (perror "ERROR")
+ (errno 0)
+ (display "ERROR: " cep)
+ (if (not (null? args))
+ (begin (display (car args) cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep))
+ (cdr args))))
+ (newline cep)
+ (cond ((stack-trace) (newline cep)))
+ (display " * Breakpoint established: (continue <val>) to return." cep)
+ (newline cep) (force-output cep)
+ (require 'debug) (apply breakpoint args))
+
+ (define (user-interrupt . args)
+ (define cep (current-error-port))
+ (newline cep) (display "ERROR: user interrupt" cep)
+ (newline cep)
+ (cond ((stack-trace) (newline cep)))
+ (display " * Breakpoint established: (continue <val>) to return." cep)
+ (newline cep) (force-output cep)
+ (require 'debug) (apply breakpoint args))
+ ))
+
+;;; ABS and MAGNITUDE can be the same.
+(cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
+ (if (defined? usr:lib)
+ (if (usr:lib "m")
+ (load (in-vicinity (implementation-vicinity) "Transcen")
+ (usr:lib "m"))
+ (load (in-vicinity (implementation-vicinity) "Transcen")))
+ (load (in-vicinity (implementation-vicinity) "Transcen"
+ (scheme-file-suffix))))
+ (set! abs magnitude)))
+
+(if (defined? array?)
+ (begin
+ (define uniform-vector? array?)
+ (define make-uniform-vector dimensions->uniform-array)
+; (define uniform-vector-ref array-ref)
+ (define (uniform-vector-set! u i o)
+ (uniform-vector-set1! u o i))
+; (define uniform-vector-fill! array-fill!)
+; (define uniform-vector-read! uniform-array-read!)
+; (define uniform-vector-write uniform-array-write)
+
+ (define (make-array fill . args)
+ (dimensions->uniform-array args () fill))
+ (define (make-uniform-array prot . args)
+ (dimensions->uniform-array args prot))
+ (define (list->array ndim lst)
+ (list->uniform-array ndim '() lst))
+ (define (list->uniform-vector prot lst)
+ (list->uniform-array 1 prot lst))
+ (define (array-shape a)
+ (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+ (array-dimensions a)))))
+
+;;;; Initialize statically linked add-ons
+(cond ((defined? scm_init_extensions)
+ (scm_init_extensions)
+ (set! scm_init_extensions #f)))
+
+;;; Use *argv* instead of (program-arguments), to allow option
+;;; processing to be done on it. "ScmInit.scm" must
+;;; (set! *argv* (program-arguments))
+;;; if it wants to alter the arguments which BOOT-TAIL processes.
+(define *argv* #f)
+
+;;; This loads the user's initialization file, or files named in
+;;; program arguments.
+
+(or
+ (eq? (software-type) 'THINKC)
+ (member "-no-init-file" (program-arguments))
+ (member "--no-init-file" (program-arguments))
+ (try-load
+ (in-vicinity
+ (let ((home (getenv "HOME")))
+ (if home
+ (case (software-type)
+ ((UNIX COHERENT)
+ (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
+ home ;V7 unix has a / on HOME
+ (string-append home "/")))
+ (else home))
+ (user-vicinity)))
+ "ScmInit.scm"))
+ (errno 0))
+
+(if (not (defined? *R4RS-macro*))
+ (define *R4RS-macro* #f))
+(if (not (defined? *interactive*))
+ (define *interactive* #f))
+
+(define (boot-tail)
+ (cond ((not *argv*) (set! *argv* (program-arguments))
+ (cond ((provided? 'getopt) (set! *optind* 1)
+ (set! *optarg* #f)))))
+ (cond
+ ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
+ (require 'getopt)
+;;; (else
+;;; (define *optind* 1)
+;;; (define getopt:opt #f)
+;;; (define (getopt argc argv optstring) #f))
+
+ (let* ((simple-opts "muqvbis")
+ (arg-opts '("a kbytes" "no-init-file" "-no-init-file"
+ "-version" "-help" "p number"
+ "r feature" "f filename" "l filename"
+ "d filename" "c string" "e string"
+ "o filename"))
+ (opts (apply string-append ":" simple-opts
+ (map (lambda (o)
+ (string-append (string (string-ref o 0)) ":"))
+ arg-opts)))
+ (argc (length *argv*))
+ (didsomething #f)
+ (moreopts #t)
+ (exe-name (symbol->string (scheme-implementation-type)))
+ (up-name (apply string (map char-upcase (string->list exe-name)))))
+
+ (define (do-thunk thunk)
+ (if *interactive*
+ (thunk)
+ (let ((complete #f))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (thunk)
+ (set! complete #t))
+ (lambda () (if (not complete) (quit #f)))))))
+
+ (define (do-string-arg)
+ (require 'string-port)
+ (do-thunk
+ (lambda ()
+ ((if *R4RS-macro* macro:eval eval)
+ (call-with-input-string
+ (string-append "(begin " *optarg* ")")
+ read))))
+ (set! didsomething #t))
+
+ (define (do-load file)
+ (do-thunk
+ (lambda ()
+ (cond (*R4RS-macro* (require 'macro) (macro:load file))
+ (else (load file)))))
+ (set! didsomething #t))
+
+ (define (usage preopt opt postopt success?)
+ (define cep (if success? (current-output-port) (current-error-port)))
+ (define indent (make-string 6 #\ ))
+ (define i 3)
+ (cond ((char? opt) (set! opt (string opt)))
+ ;;((symbol? opt) (set! opt (symbol->string opt)))
+ )
+ (display (string-append preopt opt postopt) cep)
+ (newline cep)
+ (display (string-append "Usage: "
+ exe-name
+ " [-a kbytes] [-" simple-opts "]") cep)
+ (for-each
+ (lambda (o)
+ (display (string-append " [-" o "]") cep)
+ (set! i (+ 1 i))
+ (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
+ (cdr arg-opts))
+ (display " [-- | -s | -] [file] [args...]" cep) (newline cep)
+ (if success? (display success? cep) (exit #f)))
+
+ ;; -a int => ignore (handled by run_scm)
+ ;; -c str => (eval str)
+ ;; -e str => (eval str)
+ ;; -d str => (require 'database-utilities) (open-database str)
+ ;; -f str => (load str)
+ ;; -l str => (load str)
+ ;; -r str => (require str)
+ ;; -o str => (dump str)
+ ;; -p int => (verbose int)
+ ;; -m => (set! *R4RS-macro* #t)
+ ;; -u => (set! *R4RS-macro* #f)
+ ;; -v => (verbose 3)
+ ;; -q => (verbose 0)
+ ;; -i => (set! *interactive* #t)
+ ;; -b => (set! *interactive* #f)
+ ;; -s => set argv, don't execute first one
+ ;; -no-init-file => don't load init file
+ ;; --no-init-file => don't load init file
+ ;; --help => print and exit
+ ;; --version => print and exit
+ ;; -- => last option
+
+ (let loop ((option (getopt-- argc *argv* opts)))
+ (case option
+ ((#\a)
+ (cond ((> *optind* 3)
+ (usage "scm: option `-" getopt:opt "' must be first" #f))
+ ((or (not (exact? (string->number *optarg*)))
+ (not (<= 1 (string->number *optarg*) 10000)))
+ ;; This size limit should match scm.c ^^
+ (usage "scm: option `-" getopt:opt
+ (string-append *optarg* "' unreasonable") #f))))
+ ((#\e #\c) (do-string-arg)) ;sh-like
+ ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*)
+ ((#\d) (require 'database-utilities)
+ (open-database *optarg*))
+ ((#\o) (require 'dump)
+ (if (< *optind* (length *argv*))
+ (dump *optarg* #t)
+ (dump *optarg*)))
+ ((#\r) (do-thunk (lambda ()
+ (if (and (= 1 (string-length *optarg*))
+ (char-numeric? (string-ref *optarg* 0)))
+ (case (string-ref *optarg* 0)
+ ((#\2) (require 'rev3-procedures)
+ (require 'rev2-procedures))
+ ((#\3) (require 'rev3-procedures))
+ ((#\4) (require 'rev4-optional-procedures))
+ ((#\5) (require 'dynamic-wind)
+ (require 'values)
+ (require 'macro)
+ (set! *R4RS-macro* #t))
+ (else (require (string->symbol *optarg*))))
+ (require (string->symbol *optarg*))))))
+ ((#\p) (verbose (string->number *optarg*)))
+ ((#\q) (verbose 0))
+ ((#\v) (verbose 3))
+ ((#\i) (set! *interactive* #t) ;sh-like
+ (verbose (max 2 (verbose))))
+ ((#\b) (set! didsomething #t)
+ (set! *interactive* #f))
+ ((#\s) (set! moreopts #f) ;sh-like
+ (set! didsomething #t)
+ (set! *interactive* #t))
+ ((#\m) (set! *R4RS-macro* #t))
+ ((#\u) (set! *R4RS-macro* #f))
+ ((#\n) (if (not (string=? "o-init-file" *optarg*))
+ (usage "scm: unrecognized option `-n" *optarg* "'" #f)))
+ ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f))
+ ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f))
+ ((#f) (set! moreopts #f) ;sh-like
+ (cond ((and (< *optind* (length *argv*))
+ (string=? "-" (list-ref *argv* *optind*)))
+ (set! *optind* (+ 1 *optind*)))))
+ (else
+ (or (cond ((not (string? option)) #f)
+ ((string-ci=? "no-init-file" option))
+ ((string-ci=? "version" option)
+ (display
+ (string-append exe-name " "
+ (scheme-implementation-version)
+ "
+Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+"
+ up-name
+ " may be distributed under the terms of"
+ " the GNU General Public Licence;
+certain other uses are permitted as well."
+ " For details, see the file `COPYING',
+which is included in the "
+ up-name " distribution.
+There is no warranty, to the extent permitted by law.
+"
+ ))
+ (cond ((execpath)
+ (display " This executable was loaded from ")
+ (display (execpath))
+ (newline)))
+ (quit #t))
+ ((string-ci=? "help" option)
+ (usage "This is "
+ up-name
+ ", a Scheme interpreter."
+ (string-append
+ "Latest info: "
+ "http://www-swiss.ai.mit.edu/~jaffer/"
+ up-name ".html
+"
+ ))
+ (quit #t))
+ (else #f))
+ (usage "scm: unknown option `--" option "'" #f))))
+
+ (cond ((and moreopts (< *optind* (length *argv*)))
+ (loop (getopt-- argc *argv* opts)))
+ ((< *optind* (length *argv*)) ;No more opts
+ (set! *argv* (list-tail *argv* *optind*))
+ (set! *optind* 1)
+ (cond ((not didsomething) (do-load (car *argv*))
+ (set! *optind* (+ 1 *optind*))))
+ (cond ((and (> (verbose) 2)
+ (not (= (+ -1 *optind*) (length *argv*))))
+ (display "scm: extra command arguments unused:"
+ (current-error-port))
+ (for-each (lambda (x) (display (string-append " " x)
+ (current-error-port)))
+ (list-tail *argv* (+ -1 *optind*)))
+ (newline (current-error-port)))))
+ ((and (not didsomething) (= *optind* (length *argv*)))
+ (set! *interactive* #t)))))
+
+ (cond ((not *interactive*) (quit))
+ (*R4RS-macro*
+ (require 'repl)
+ (require 'macro)
+ (let* ((oquit quit))
+ (set! quit (lambda () (repl:quit)))
+ (set! exit quit)
+ (repl:top-level macro:eval)
+ (oquit))))
+ ;;otherwise, fall into non-macro SCM repl.
+ )
+ (else
+ (begin (errno 0)
+ (set! *interactive* #t)
+ (for-each load (cdr (program-arguments)))))))
diff --git a/Link.scm b/Link.scm
new file mode 100644
index 0000000..ad88e47
--- /dev/null
+++ b/Link.scm
@@ -0,0 +1,284 @@
+;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Link.scm", Compiling and dynamic linking code for SCM.
+;;; Author: Aubrey Jaffer.
+
+(define cc:command
+ (let ((default "cc -c")) ;-O removed for HP-UX self-compile
+ (case (software-type)
+ ((unix) (if (memq 'sun-dl *features*)
+ "gcc -g -O -fpic -c" ; If you have problems change -fpic to
+ ; -fPIC (see GCC info pages).
+ default))
+ (else default))))
+
+(define link:command
+ (case (software-type)
+ (else "cc")))
+
+(define scm:object-suffix
+ (case (software-type)
+ ((MSDOS VMS) ".OBJ")
+ (else (if (provided? 'sun-dl) ".so" ".o"))))
+
+;;; This is an unusual autoload because it should load either the
+;;; source or compiled version if present.
+(if (not (defined? hobbit)) ;Autoload for hobbit
+ (define (hobbit . args)
+ (require (in-vicinity (implementation-vicinity) "hobbit"))
+ (provide 'hobbit)
+ (apply hobbit args)))
+
+(define (compile-file file . args)
+ (apply hobbit file args)
+ (require (in-vicinity (implementation-vicinity) "build"))
+ (build-from-whole-argv
+ (list "build" "-tdll"
+ (string-append "--compiler-options=-I" (implementation-vicinity))
+ "-c"
+ (string-append (descmify file) ".c")
+ ;; or (replace-suffix file (scheme-file-suffix) ".c")
+ "-hsystem"
+ )))
+
+(define (link-named-scm name . modules)
+ (require (in-vicinity (implementation-vicinity) "build"))
+ (let* ((iv (implementation-vicinity))
+ (oss (string-append scm:object-suffix " "))
+ (command
+ (list "build" "--type=exe" "-cscm.c" "-hsystem"
+ (string-append "--linker-options=-L" (implementation-vicinity))
+ (apply string-append
+ "-i"
+ (map (lambda (n)
+ (string-append "init_" n))
+ modules))
+ (apply string-append
+ "-j"
+ (map (lambda (n)
+ (string-append n oss)) modules))
+ "-o" name)))
+ (cond ((>= (verbose) 3)
+ (write command) (newline)))
+ (build-from-whole-argv command)))
+
+;;;; Dynamic linking/loading
+
+(cond
+ ((defined? dyn:link)
+ (define link:modules '())
+ (define link:able-suffix
+ (cond ((provided? 'shl) ".sl")
+ ((provided? 'sun-dl) ".so")
+ (else ".o")))
+ (define link:link
+ (lambda (file . libs)
+ (define oloadpath *load-pathname*)
+ (let* ((sl (string-length file))
+ (lasl (string-length link:able-suffix))
+ (*vicinity-suffix*
+ (case (software-type)
+ ((NOSVE) '(#\: #\.))
+ ((AMIGA) '(#\: #\/))
+ ((UNIX) '(#\/))
+ ((VMS) '(#\: #\]))
+ ((MSDOS ATARIST OS/2) '(#\\))
+ ((MACOS THINKC) '(#\:))))
+ (fname (let loop ((i (- sl 1)))
+ (cond ((negative? i) file)
+ ((memv (string-ref file i) *vicinity-suffix*)
+ (substring file (+ i 1) sl))
+ (else (loop (- i 1))))))
+ (nsl (string-length fname))
+ (name (cond ((< nsl lasl) fname)
+ ((string-ci=? (substring fname (- nsl lasl) nsl)
+ link:able-suffix)
+ (substring fname 0 (- nsl lasl)))
+ (else fname)))
+ (linkobj #f))
+ (set! *load-pathname* file)
+ (set! linkobj (assoc name link:modules))
+ (cond (linkobj (dyn:unlink (cdr linkobj))))
+ (set! linkobj (dyn:link file))
+ (for-each (lambda (lib)
+ (cond ((dyn:link lib))
+ (else (slib:error "couldn't link: " lib))))
+ libs)
+ (cond ((not linkobj)
+ (set! *load-pathname* oloadpath) #f)
+ ((dyn:call
+ (string-append
+ "init_" (list->string (map char-downcase (string->list name))))
+ linkobj)
+ (set! link:modules (acons name linkobj link:modules))
+ (set! *load-pathname* oloadpath) #t)
+ (else
+ (dyn:unlink linkobj)
+ (set! *load-pathname* oloadpath) #f)))))))
+
+(cond
+ ((defined? vms:dynamic-link-call)
+ (define link:able-suffix #f)
+ (define (link:link file)
+ (define dir "")
+ (define fil "")
+ (let loop ((i (- (string-length file) 1)))
+ (cond ((negative? i) (set! dir file))
+ ((memv (string-ref file i) '(#\: #\]))
+ (set! dir (substring file 0 (+ i 1)))
+ (set! fil (substring file (+ i 1) (string-length file))))
+ (else (loop (- i 1)))))
+ (vms:dynamic-link-call dir fil (string-append "init_" fil)))))
+
+(set! *catalog*
+ (acons 'scmhob (in-vicinity (implementation-vicinity) "scmhob")
+ *catalog*))
+(and (defined? *catalog*) (defined? link:link)
+ (cond ((provided? 'dld:dyncm)
+ (define (usr:lib lib)
+ (or (and (member lib '("c" "m"))
+ (let ((sa (string-append "/usr/lib/lib" lib ".sa")))
+ (and (file-exists? sa) sa)))
+ (string-append "/usr/lib/lib" lib ".a")))
+ (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))
+ ((provided? 'sun-dl)
+ ;; These libraries are (deferred) linked in conversion to ".so"
+ (define (usr:lib lib) #f)
+ (define (x:lib lib) #f))
+ ((provided? 'shl)
+ (define (usr:lib lib)
+ (if (member lib '("c" "m"))
+ (string-append "/lib/lib" lib link:able-suffix)
+ (string-append "/usr/lib/lib" lib link:able-suffix)))
+ (define (x:lib lib) (string-append "/usr/X11R5/lib/lib"
+ lib link:able-suffix)))
+ (else
+ (define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
+ (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))
+ (begin
+ (define wb:vicinity (string-append (implementation-vicinity) "../wb/"))
+ (define (catalog:add-link feature ofile . libs)
+ (define fe (file-exists? ofile))
+ (cond ((or (not (require:feature->path feature)) fe)
+ ;; remove #f from libs list
+ (set! libs (let rem ((l libs))
+ (cond ((null? l) l)
+ ((car l) (cons (car l) (rem (cdr l))))
+ (else (rem (cdr l))))))
+ (set! *catalog*
+ (acons feature (cons 'compiled (cons ofile libs))
+ *catalog*))
+ fe)
+ (else #f)))
+ (set! *catalog*
+ (acons 'wb-table (in-vicinity wb:vicinity "wbtab") *catalog*))
+ (catalog:add-link 'db
+ (in-vicinity wb:vicinity "db" link:able-suffix)
+ (in-vicinity wb:vicinity "handle" link:able-suffix)
+ (in-vicinity wb:vicinity "blink" link:able-suffix)
+ (in-vicinity wb:vicinity "prev" link:able-suffix)
+ (in-vicinity wb:vicinity "ent" link:able-suffix)
+ (in-vicinity wb:vicinity "sys" link:able-suffix)
+ (in-vicinity wb:vicinity "del" link:able-suffix)
+ (in-vicinity wb:vicinity "stats" link:able-suffix)
+ (in-vicinity wb:vicinity "blkio" link:able-suffix)
+ (in-vicinity wb:vicinity "scan" link:able-suffix)
+ (usr:lib "c"))
+ (set! *catalog* (cons '(wb . db) *catalog*))
+ (catalog:add-link 'turtle-graphics
+ (in-vicinity (implementation-vicinity) "turtlegr"
+ link:able-suffix)
+ (x:lib "X11")
+ (usr:lib "m")
+ (usr:lib "c"))
+ (catalog:add-link 'curses
+ (in-vicinity (implementation-vicinity) "crs"
+ link:able-suffix)
+ (usr:lib "ncurses")
+ ;;(usr:lib "curses")
+ ;;(usr:lib "termcap")
+ (usr:lib "c"))
+ (catalog:add-link 'edit-line
+ (in-vicinity (implementation-vicinity) "edline"
+ link:able-suffix)
+ (usr:lib "edit")
+ (usr:lib "termcap")
+ (usr:lib "c"))
+ (catalog:add-link 'regex
+ (in-vicinity (implementation-vicinity) "rgx"
+ link:able-suffix)
+ (usr:lib "c"))
+ (catalog:add-link 'unix
+ (in-vicinity (implementation-vicinity) "unix"
+ link:able-suffix)
+ (in-vicinity (implementation-vicinity) "ioext"
+ link:able-suffix)
+ (usr:lib "c"))
+ (catalog:add-link 'posix
+ (in-vicinity (implementation-vicinity) "posix"
+ link:able-suffix)
+ (usr:lib "c"))
+ (catalog:add-link 'socket
+ (in-vicinity (implementation-vicinity) "socket"
+ link:able-suffix)
+ (usr:lib "c"))
+ (cond ((catalog:add-link 'i/o-extensions
+ (in-vicinity (implementation-vicinity) "ioext"
+ link:able-suffix)
+ (usr:lib "c"))
+ (set! *catalog* (append '((line-i/o . i/o-extensions)
+ (pipe . i/o-extensions))
+ *catalog*))))
+ (cond ((catalog:add-link 'rev2-procedures
+ (in-vicinity (implementation-vicinity) "sc2"
+ link:able-suffix))
+ (set! *catalog* (cons '(rev3-procedures . rev2-procedures)
+ *catalog*))))
+ (catalog:add-link 'record
+ (in-vicinity (implementation-vicinity) "record"
+ link:able-suffix))
+ (catalog:add-link 'generalized-c-arguments
+ (in-vicinity (implementation-vicinity) "gsubr"
+ link:able-suffix))
+ (catalog:add-link 'array-for-each
+ (in-vicinity (implementation-vicinity) "ramap"
+ link:able-suffix))
+ ))
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..2bb47f6
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,384 @@
+# Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this software; see the file COPYING. If not, write to
+# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+# As a special exception, the Free Software Foundation gives permission
+# for additional uses of the text contained in its release of GUILE.
+#
+# The exception is that, if you link the GUILE library with other files
+# to produce an executable, this does not by itself cause the
+# resulting executable to be covered by the GNU General Public License.
+# Your use of that executable is in no way restricted on account of
+# linking the GUILE library code into it.
+#
+# This exception does not however invalidate any other reasons why
+# the executable file might be covered by the GNU General Public License.
+#
+# This exception applies only to the code released by the
+# Free Software Foundation under the name GUILE. If you copy
+# code from other Free Software Foundation releases into a copy of
+# GUILE, as the General Public License permits, the exception does
+# not apply to the code that you add in this way. To avoid misleading
+# anyone as to the status of such modified files, you must delete
+# this exception notice from them.
+#
+# If you write modifications of your own for GUILE, it is your choice
+# whether to permit this exception to apply to your modifications.
+# If you do not wish that, delete this exception notice.
+
+# "Makefile" for scm4e6 Scheme Interpreter
+# Author: Aubrey Jaffer
+
+SHELL = /bin/sh
+#CC =
+CFLAGS = #-g
+#LIBS =
+LD = $(CC) #-g
+
+# directory where COPYING and Init.scm reside.
+#IMPLPATH = /usr/local/src/scm/
+#this one is good for bootstrapping
+IMPLPATH = `pwd`/
+# Pathname where Init.scm resides.
+IMPLINIT = $(IMPLPATH)Init.scm
+DFLAG = -DIMPLINIT=\"$(IMPLINIT)\"
+
+# If pathname where Init.scm resides is not known in advance then
+# SCM_INIT_PATH is the environment variable whose value is the
+# pathname where Init.scm resides.
+
+intro:
+ @echo
+ @echo "This is scm$(VERSION). Read \"scm.info\" (from \"scm.texi\")"
+ @echo "to learn how to build and install SCM."
+ @echo "Here is a quick guide:"
+ @echo
+ @echo " From: bos@scrg.cs.tcd.ie"
+ @echo " Build and install scripts using GNU autoconf are"
+ @echo " available as scmconfig.tar.gz in the SCM distribution"
+ @echo " directories. See README.unix in scmconfig.tar.gz for"
+ @echo " further instructions."
+ @echo
+ @echo " Alternatively:"
+ @echo " make scmlit"
+ @echo
+ @echo " If you are on a non-unix system, create an empty file"
+ @echo " \"scmflags.h\". Then compile time.c, repl.c, scl.c,"
+ @echo " sys.c, eval.c, subr.c, unif.c, and rope.c. Then link"
+ @echo " them to create a \"scmlit\" executable."
+ @echo
+ @echo " Once you have built scmlit successfully, test it:"
+ @echo " make checklit"
+ @echo " If this reports no errors, use scmlit to build.scm"
+ @echo " fancier versions of scm, with optional features."
+
+ofiles = time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \
+ continue.o findexec.o
+# ramap.o
+
+all: scmlit
+scmlit: $(ofiles) scm.o
+ $(LD) -o scmlit $(ofiles) scm.o $(LIBS)
+scm.o: scm.c scm.h scmfig.h patchlvl.h scmflags.h
+ $(CC) $(CFLAGS) -c $(DFLAG) scm.c
+scmflags.h: scmflags
+scmflags:
+ echo "#ifndef IMPLINIT" > scmflags.h
+ echo "#define IMPLINIT \"$(IMPLINIT)\"" >> scmflags.h
+ echo "#endif" >> scmflags.h
+
+.c.o:
+ $(CC) -c $(CFLAGS) $< -o $@
+scl.o: scl.c scm.h scmfig.h scmflags.h
+eval.o: eval.c scm.h scmfig.h scmflags.h setjump.h
+unif.o: unif.c scm.h scmfig.h scmflags.h
+#ramap.o: ramap.c scm.h scmfig.h scmflags.h
+repl.o: repl.c scm.h scmfig.h scmflags.h setjump.h
+sys.o: sys.c scm.h scmfig.h scmflags.h setjump.h
+time.o: time.c scm.h scmfig.h scmflags.h
+subr.o: subr.c scm.h scmfig.h scmflags.h
+rope.o: rope.c scm.h scmfig.h scmflags.h
+continue.o: continue.c continue.h setjump.h
+ $(CC) $(CFLAGS) -c continue.c
+
+srcdir=$(HOME)/scm/
+
+udscm:
+ $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ engineering-notation dump dynamic-linking -o udscm
+
+myscm: udscm $(ifiles)
+ ./udscm -o scm
+mylib:
+ $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ engineering-notation dump dynamic-linking -tlib
+pgscm:
+ $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ engineering-notation dump dynamic-linking -o udscm \
+ --compiler-options=-pg --linker-options=-pg
+ ./udscm -o pgscm
+mydebug:
+ $(srcdir)build.scm -hsystem -Fcautious bignums arrays inexact \
+ engineering-notation dump dynamic-linking debug -ogdbscm \
+ --compiler-options=-Wall --linker-options=-Wall
+mydlls:
+ $(srcdir)build.scm -h system -t dll -c sc2.c rgx.c crs.c edline.c \
+ record.c gsubr.c ioext.c posix.c unix.c socket.c \
+ ramap.c
+myturtle:
+ $(srcdir)build.scm -h system -F turtlegr -t dll
+
+checklit: r4rstest.scm
+ ./scmlit -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
+check: r4rstest.scm
+ ./scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
+bench:
+ echo `whoami`@`hostname` testing scm >> BenchLog
+ echo on `date` >> BenchLog
+ ls -l scm >> BenchLog
+ size scm >> BenchLog
+ uname -a >> BenchLog
+ ./scm -lbench.scm
+ cat bench.log >> BenchLog
+ echo >> BenchLog
+ echo
+ tail -20 BenchLog
+benchlit:
+ echo `whoami`@`hostname` testing scmlit >> BenchLog
+ echo on `date` >> BenchLog
+ ls -l scmlit >> BenchLog
+ size scmlit >> BenchLog
+ uname -a >> BenchLog
+ ./scmlit -lbench.scm
+ cat bench.log >> BenchLog
+ echo >> BenchLog
+ echo
+ tail -20 BenchLog
+
+dvidir=../dvi/
+dvi: $(dvidir)scm.dvi
+$(dvidir)scm.dvi: $(srcdir)scm.texi $(dvidir)scm.fn Makefile
+# cd $(dvidir);texi2dvi $(srcdir)scm.texi
+ -(cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;texindex scm.??)
+ cd $(dvidir);export set TEXINPUTS=$(srcdir):$$TEXINPUTS;tex $(srcdir)scm.texi
+$(dvidir)scm.fn:
+ cd $(dvidir);tex $(srcdir)scm.texi
+xdvi: $(dvidir)scm.dvi
+ xdvi -s 3 $(dvidir)scm.dvi
+htmldir=../public_html/
+html: $(htmldir)scm_toc.html
+$(htmldir)scm_toc.html: $(srcdir)scm.texi
+ cd $(htmldir);make scm_toc.html
+
+################ INSTALL DEFINITIONS ################
+
+prefix = /usr/local/
+exec_prefix = $(prefix)/
+# directory where `make install' will put executable.
+bindir = $(exec_prefix)bin/
+libdir = $(exec_prefix)lib/
+# directory where `make install' will put manual page.
+man1dir = $(prefix)man/man1/
+infodir = $(prefix)info/
+includedir = $(prefix)include/
+
+info: $(infodir)/scm.info
+$(infodir)/scm.info: scm.texi
+ makeinfo scm.texi -o $(infodir)/scm.info
+
+infoz: $(infodir)/scm.info.gz
+$(infodir)/scm.info.gz: $(infodir)/scm.info
+ -rm $(infodir)/scm.info*.gz
+ gzip $(infodir)/scm.info*
+
+install: scm.1
+ test -d $(bindir) || mkdir $(bindir)
+ test -d $(man1dir) || mkdir $(man1dir)
+ -cp scm $(bindir)
+ -strip $(bindir)scm
+ -cp scm.1 $(man1dir)
+ test -d $(IMPLPATH) || mkdir $(IMPLPATH)
+ -cp Init.scm $(IMPLPATH)
+ -cp Link.scm $(IMPLPATH)
+ -cp Transcen.scm $(IMPLPATH)
+ -cp COPYING $(IMPLPATH)
+
+installlib:
+ test -d $(includedir) || mkdir $(includedir)
+ cp scm.h $(includedir)scm.h
+ cp scmfig.h $(includedir)scmfig.h
+ test -d $(libdir) || mkdir $(libdir)
+ cp libscm.a $(libdir)libscm.a
+
+uninstall:
+ -rm $(bindir)scm
+ -rm $(man1dir)scm.1
+ -rm $(includedir)scm.h
+ -rm $(includedir)scmfig.h
+ -rm $(libdir)libscm.a
+# -rm $(IMPLPATH)Init.scm
+# -cp $(IMPLPATH)Link.scm
+# -rm $(IMPLPATH)Transcen.scm
+# -rm $(IMPLPATH)COPYING
+
+scm.doc: scm.1
+ nroff -man $< | ul -tunknown >$@
+
+#### Stuff for maintaining SCM below ####
+
+VERSION = 4e6
+ver = $(VERSION)
+RM_R = rm -rf
+cfiles = scm.c time.c repl.c ioext.c scl.c sys.c eval.c subr.c sc2.c \
+ unif.c rgx.c crs.c dynl.c record.c posix.c socket.c unix.c \
+ rope.c ramap.c gsubr.c edline.c Iedline.scm continue.c \
+ findexec.c
+ufiles = pre-crt0.c ecrt0.c gmalloc.c unexec.c unexelf.c
+confiles = scmconfig.h.in mkinstalldirs acconfig-1.5.h install-sh \
+ configure configure.in Makefile.in COPYING README.unix
+
+hfiles = scm.h scmfig.h setjump.h patchlvl.h continue.h
+ifiles = Init.scm Transcen.scm Link.scm
+tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm
+dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \
+ scm.texi ChangeLog
+mfiles = Makefile build.scm build.bat
+vfiles = setjump.mar setjump.s
+afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \
+ $(vfiles) $(ufiles)
+
+makedev = make -f $(HOME)/makefile.dev
+CHPAT=$(HOME)/bin/chpat
+dest = $(HOME)/dist/
+temp/scm: $(afiles)
+ -$(RM_R) temp
+ mkdir temp
+ mkdir temp/scm
+ ln $(afiles) temp/scm
+
+dist: $(dest)scm$(VERSION).tar.gz
+$(dest)scm$(VERSION).tar.gz: temp/scm
+ $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) tar.gz
+shar: scm.shar
+scm.shar: temp/scm
+ $(makedev) PROD=scm shar
+dclshar: scm.com
+com: scm.com
+scm.com: temp/scm
+ $(makedev) PROD=scm com
+zip: scm.zip
+scm.zip: temp/scm
+ $(makedev) PROD=scm zip
+distzip: scm$(VERSION).zip
+scm$(VERSION).zip: temp/scm turtle turtlegr.c grtest.scm require.scm
+ $(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip
+ cd ..; zip -9ur $(dest)scm$(VERSION).zip \
+ scm/turtle scm/turtlegr.c scm/grtest.scm scm/require.scm
+ mv $(dest)scm$(VERSION).zip /c/scm/dist/
+pubzip: temp/scm
+ $(makedev) DEST=$(HOME)/pub/ PROD=scm zip
+
+diffs: pubdiffs
+pubdiffs: temp/scm
+ $(makedev) DEST=$(HOME)/pub/ PROD=scm pubdiffs
+distdiffs: temp/scm
+ $(makedev) DEST=$(dest) PROD=scm ver=$(ver) distdiffs
+
+
+HOBBITVERSION = 4d
+hobfiles = README.hob hobbit.doc hobbit.tms hobbit.scm scmhob.h
+
+hobtemp/scm: $(hobfiles)
+ -$(RM_R) hobtemp
+ mkdir hobtemp
+ mkdir hobtemp/scm
+ ln $(hobfiles) hobtemp/scm
+
+hobdist: $(dest)hobbit$(HOBBITVERSION).tar.gz
+$(dest)hobbit$(HOBBITVERSION).tar.gz: hobtemp/scm
+ $(makedev) DEST=$(dest) PROD=scm ver=-hob$(HOBBITVERSION) \
+ tar.gz TEMP=hobtemp/
+ mv $(dest)scm-hob$(HOBBITVERSION).tar.gz \
+ $(dest)hobbit$(HOBBITVERSION).tar.gz
+hobbit$(HOBBITVERSION).zip: hobtemp/scm
+ $(makedev) TEMP=hobtemp/ name=hobbit$(HOBBITVERSION) PROD=scm zip
+
+new:
+ $(CHPAT) scm$(VERSION) scm$(ver) ANNOUNCE ../jacal/ANNOUNCE \
+ ../wb/README ../wb/ANNOUNCE \
+ ../public_html/README.html ../dist/README \
+ ../public_html/SLIB.html ../public_html/JACAL.html \
+ ../public_html/SCM.html ../public_html/Hobbit.html \
+ /c/scm/dist/install.bat /c/scm/dist/makefile \
+ /c/scm/dist/mkdisk.bat
+ $(CHPAT) $(VERSION) $(ver) README scm.texi patchlvl.h \
+ Init.scm ../public_html/SCM.html Makefile
+
+configtemp/scm: $(confiles)
+ -$(RM_R) configtemp/scm
+ -mkdir configtemp
+ mkdir configtemp/scm
+ ln $(confiles) configtemp/scm
+confdist: scmconfig.tar.gz
+scmconfig.tar.gz: configtemp/scm
+ cd configtemp; tar cohf ../scmconfig.tar scm
+ chmod 664 scmconfig.tar
+ -rm -f scmconfig.tar.*z
+ gzip scmconfig.tar
+ chmod 664 scmconfig.tar.*z
+
+lint: lints
+lints: $(cfiles) $(hfiles)
+ lint $(CPPFLAGS) $(ALL_CFLAGS) $(cfiles) | tee lints
+# lint $(CPPFLAGS) $(ALL_CFLAGS) $(cfiles) | tee lintes
+
+#seds to help find names not unique in first 8 characters (name8s)
+# for BSD nm format
+SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//' -e 's/.* T //'
+#old, bad for T [^_] on suns: SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//'
+# For a System V nm where plain C identifiers have _ prepended:
+#SED_TO_STRIP_NM=sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//'
+# For a System V nm where plain C identifiers have nothing prepended:
+#SED_TO_STRIP_NM=sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g'
+
+name8: name8s
+name8s: scm
+ nm scm |\
+ $(SED_TO_STRIP_NM) |\
+ sort -u|\
+ awk '{ if (substr(l,1,8)==substr($$1,1,8)) {\
+ if (p) print l;\
+ print $$1;p=0;stat=1\
+ }else p=1;\
+ l=$$1\
+ }END{exit stat}' -
+ctags: $(hfiles) $(cfiles)
+ etags $(hfiles) $(cfiles)
+TAGS:
+tags: $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\
+ hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog
+ etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) $(ufiles)\
+ hobbit.scm scm.texi README build.scm # $(mfiles) ChangeLog
+mostlyclean:
+clean:
+ -rm -f *~ *.bak *.orig *.rej core a.out ramap.o $(ofiles) scm.o \
+ lints tmp* \#* *\#
+ -$(RM_R) *temp
+distclean: clean
+ -rm -f $(EXECFILES) *.o a.out TAGS
+realclean: distclean
+ -rm -f scm.doc
+realempty: temp/scm
+ -rm -f $(afiles)
diff --git a/Makefile.in b/Makefile.in
new file mode 100644
index 0000000..c2f69c5
--- /dev/null
+++ b/Makefile.in
@@ -0,0 +1,462 @@
+# Copyright (C) 1990, 1991, 1992, 1993 Aubrey Jaffer. -*- Makefile -*-
+# This file is part of SCM.
+#
+# SCM is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the
+# Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# SCM is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+# License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with SCM; see the file COPYING. If not, write to the Free
+# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+#
+# Makefile for SCM
+#
+
+# Ultrix 2.2 make doesn't expand the value of VPATH.
+srcdir = @srcdir@
+
+CC = @CC@
+
+CFLAGS = @CFLAGS@ -I. -I$(srcdir)
+LDFLAGS = @LDFLAGS@
+
+# Define these for your system as follows:
+# -DRTL To create a run-time library only (no
+# interactive front end).
+# -DRECKLESS To turn most SCM error schecking off.
+# -DCAUTIOUS To always check the number of arguments to
+# interpreted closures.
+# -DIO_EXTENSIONS To get primitives such as chdir, delete-file,
+# file-opisition, and pipes.
+# -DPROMPT=\"..\" To change the default prompt.
+# -DFLOATS To turn on support for inexact numbers.
+# -DSINGLES To use single-precision floats (if a float is
+# the same size as a long).
+# -DSINGLESONLY To make all inexact real numbers to be single
+# precision. Only useful if SINGLES is also
+# defined.
+# -DGC_FREE_SEGMENTS
+# To have all segments of unused heap be freed
+# up after garbage collection. Do not define if
+# you never want the heap to shrink.
+# -DTICKS If you want the ticks and ticks-interrupt
+# functions defined.
+# -DBRACKETS_AS_PARENS
+# To have square brackets read as parentheses
+# in forms.
+# -DMEMOIZE_LOCALS To speed up most local variable references.
+# You will need to remove this and recompile
+# eval.c if you use very large or deep
+# environments (more than 4095 bound variables
+# in one procedure).
+# -DENGNOT To use engineering notation instead of
+# scientific notation.
+# -DSICP To make SCM more compatible with the Scheme used
+# in Abelson & Sussman's book.
+# -DSTACK_LIMIT To limit the maximum growth of the stack (you
+# almost certainly don't want this).
+# See also `scmconfig.h' and `scmfig.h'.
+defines = @DEFS@ \
+ -DCAUTIOUS -DARRAYS -DBIGNUMS -DCCLO \
+ -DFLOATS -DIO_EXTENSIONS -DMEMOIZE_LOCALS -DGC_FREE_SEGMENTS
+
+# If you are using user extension files, change INITS and FINALS
+# below. INITS makes up the initialization calls for user extension
+# files. FINALS defines the finalization calls for user extension
+# files.
+
+# File INITS FINALS functions defined
+#
+# sc2.c init_sc2\(\) substring-move-left!,
+# substring-move-right!,
+# substring-fill!, append!, last-pair
+# rgx.c init_rgx\(\) regcomp, regexec (POSIX)
+# crs.c init_curses\(\) lendwin\(\) ... lots ...
+
+INITS = -DINITS=init_sc2\(\)\;
+FINALS = -DFINALS=\;
+
+# If you are using rgx.c, set the next line to point to the include
+# directory where your POSIX regexp include files live (if you are using
+# GNU regex).
+# RGXFLAGS = -I/archive/regex-0.11/
+
+# If your system needs extra libraries loaded in, define them here.
+# -lm For floating point math (needed).
+# -lcurses For crs.c extensions.
+# -lncurses For curses on Linux (curses has bugs).
+# -lterm{cap,lib} May be required for curses support.
+# -lregex For POSIX regexp support (rgx.c).
+LOADLIBES = @LIBS@ -lm
+
+# Any extra object files your system needs.
+extras = @LIBOBJS@
+
+# Common prefix for machine-independent installed files.
+prefix = /usr/local
+# Common prefix for machine-dependent installed files.
+exec_prefix = $(prefix)
+
+# Name under which to install SCM.
+instname = scm
+# Directory to install `scm' in.
+bindir = $(exec_prefix)/bin
+# Directory in which to install Init.scm, COPYING, and Transcen.scm.
+libdir = $(exec_prefix)/lib/scm
+# Directory to search by default for included makefiles.
+includedir = $(prefix)/include
+# Directory to install the Info files in.
+infodir = $(prefix)/info
+# Directory to install the man page in.
+mandir = $(prefix)/man/man$(manext)
+# Number to put on the man page filename.
+manext = 1
+# Directory to perform pre-install tests in.
+testdir = $(srcdir)
+
+# Program to install `scm'.
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+# Program to install the man page.
+INSTALL_DATA = @INSTALL_DATA@
+# Generic install program.
+INSTALL = @INSTALL@
+
+# Program to format Texinfo source into Info files.
+MAKEINFO = makeinfo
+# Program to format Texinfo source into DVI files.
+TEXI2DVI = texi2dvi
+
+# Programs to make tags files.
+ETAGS = etags
+CTAGS = ctags -tw
+
+# You should not need to change below this line.
+
+SHELL = /bin/sh
+DFLAG = -DIMPLINIT=\"$(libdir)/Init.scm\"
+TDFLAG = -DIMPLINIT=\"$(testdir)/Init.scm\"
+# nunix = nonunix
+nunix = $(srcdir)
+# examples = examples
+examples = $(srcdir)
+ffiles = continue.o time.o repl.o fscl.o sys.o feval.o subr.o sc2.o \
+funif.o rope.o ramap.o findexec.o #rgx.o
+fifiles = continue.o time.o repl.o iscm.o fscl.o sys.o feval.o subr.o \
+sc2.o funif.o rope.o ramap.o findexec.o #rgx.o
+efiles = time.o repl.o escl.o sys.o eeval.o subr.o sc2.o eunif.o #rgx.o
+cfiles = $(srcdir)/scm.c $(srcdir)/time.c $(srcdir)/repl.c \
+ $(srcdir)/scl.c $(srcdir)/sys.c $(srcdir)/eval.c \
+ $(srcdir)/subr.c $(srcdir)/sc2.c $(srcdir)/unif.c \
+ $(srcdir)/rgx.c $(srcdir)/crs.c $(srcdir)/dynl.c $(srcdir)/findexec.c
+hfiles = $(srcdir)/scm.h $(srcdir)/scmfig.h scmconfig.h \
+ $(srcdir)/setjump.h $(srcdir)/patchlvl.h
+ifiles = Init.scm Transcen.scm
+tfiles = $(examples)/test.scm $(examples)/example.scm \
+ $(examples)/pi.scm $(examples)/pi.c $(examples)/split.scm
+dfiles = $(srcdir)/README $(srcdir)/COPYING $(srcdir)/scm.1 \
+ $(srcdir)/QUICKREF $(srcdir)/MANUAL $(srcdir)/ChangeLog \
+ $(srcdir)/code.doc $(srcdir)/ANNOUNCE
+mfiles = Makefile $(nunix)/makefile.msc $(nunix)/makefile.bor \
+ $(nunix)/makefile.tur $(nunix)/makefile.djg \
+ $(nunix)/makefile.emx $(nunix)/makefile.qc \
+ $(nunix)/compile.amiga $(nunix)/link.amiga \
+ $(nunix)/makefile.aztec $(nunix)/makefile.ast \
+ $(nunix)/makefile.prj $(nunix)/dmakefile \
+ $(nunix)/makefile.wcc
+vfiles = $(nunix)/setjump.mar $(nunix)/VMSBUILD.COM $(nunix)/VMSGCC.COM
+afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) $(vfiles)
+
+.SUFFIXES:
+.SUFFIXES: .o .c .h .ps .dvi .info .texinfo .scm
+
+.PHONY: all
+all: scm
+
+# -DINITS= the initialization calls for user extension files.
+# -DFINALS= the finalialization calls for user extension files.
+dbscm: escm.a sc2.o $(srcdir)/../wb/db.a $(srcdir)/scm.c $(srcdir)/scm.h \
+ $(srcdir)/scmfig.h $(srcdir)/patchlvl.h Makefile
+ $(CC) -o dbscm $(CFLAGS) $(INITS)init_db\(\)\;init_rgx\(\) \
+ $(FINALS)final_db\(\) $(defines) $(srcdir)/scm.c \
+ escm.a $(srcdir)/../wb/db.a $(LOADLIBES) $(extras)
+ rm escm.a
+curscm: escm.a crs.o
+ $(CC) -o curscm $(CFLAGS) $(INITS)init_curses\(\)\;init_rgx\(\) \
+ $(FINALS)lendwin\(\) $(srcdir)/scm.c crs.o escm.a -lcurses \
+ $(LOADLIBES) $(extras)
+ rm escm.a
+dscm: dscm.a main.o
+ $(CC) -o dscm $(CFLAGS) main.o -ldld
+dscm.a: $(efiles) Makefile dynl.o $(srcdir)/scm.c
+ $(CC) $(CFLAGS) -DRTL $(INITS)init_dynl\(\) -c $(srcdir)/scm.c
+ ar crvs dscm.a scm.o dynl.o $(efiles) $(LOADLIBES)
+dynl.o: $(srcdir)/dynl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ Makefile
+ $(CC) $(CFLAGS) -DDLD -DRTL -c $(srcdir)/dynl.c
+
+instscm: $(fifiles)
+ $(CC) -o instscm $(fifiles) $(LOADLIBES) $(extras)
+
+scm: $(ffiles) fscm.o
+ $(CC) -o scm $(ffiles) fscm.o $(LOADLIBES) $(extras)
+fscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h $(srcdir)/patchlvl.h
+ $(CC) $(CFLAGS) $(TDFLAG) $(defines) -c $(FFLAGS) $(INITS) \
+ $(FINALS) $(srcdir)/scm.c
+ mv scm.o fscm.o
+
+iscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h $(srcdir)/patchlvl.h
+ $(CC) $(CFLAGS) $(DFLAG) $(defines) -c $(FFLAGS) $(INITS) \
+ $(FINALS) $(srcdir)/scm.c
+ mv scm.o iscm.o
+
+fscl.o: $(srcdir)/scl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/scl.c
+ mv scl.o fscl.o
+feval.o: $(srcdir)/eval.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/eval.c
+ mv eval.o feval.o
+funif.o: $(srcdir)/unif.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) $(srcdir)/unif.c
+ mv unif.o funif.o
+
+escm: $(efiles) escm.o
+ $(CC) -o escm $(efiles) escm.o $(LOADLIBES) $(extras)
+escm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h $(srcdir)/patchlvl.h
+ $(CC) $(CFLAGS) $(defines) -c $(INITS) $(FINALS) $(srcdir)/scm.c
+ mv scm.o escm.o
+escl.o: $(srcdir)/scl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/scl.c
+ mv scl.o escl.o
+eeval.o: $(srcdir)/eval.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/eval.c
+ mv eval.o eeval.o
+eunif.o: $(srcdir)/unif.c $(srcdir)/scm.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c unif.c
+ mv unif.o eunif.o
+
+repl.o: $(srcdir)/repl.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/setjump.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(TDFLAG) $(srcdir)/repl.c
+sys.o: $(srcdir)/sys.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/setjump.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/sys.c
+continue.o: $(srcdir)/continue.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/setjump.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/continue.c
+rope.o: $(srcdir)/rope.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/setjump.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/rope.c
+ramap.o: $(srcdir)/ramap.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/setjump.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/ramap.c
+time.o: $(srcdir)/time.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/time.c
+subr.o: $(srcdir)/subr.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/subr.c
+sc2.o: $(srcdir)/sc2.c $(srcdir)/scm.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/sc2.c
+rgx.o: $(srcdir)/rgx.c $(srcdir)/scm.h Makefile scmconfig.h
+ $(CC) $(CFLAGS) $(defines) $(RGXFLAGS) -c rgx.c
+crs.o: $(srcdir)/crs.c $(srcdir)/scm.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c crs.c
+findexec.o: $(srcdir)/findexec.c
+ $(CC) $(CFLAGS) $(defines) -c $(srcdir)/findexec.c
+
+both: scm escm
+
+$(srcdir)/proto.h: $(cfiles)
+ rm -f $(srcdir)/proto.h
+ mkproto $(cfiles) > $(srcdir)/proto.h
+
+libscm.a: rtlscm.o $(ffiles)
+ rm -f libscm.a
+ ar rc libscm.a rtlscm.o $(ffiles)
+ $(RANLIB) libscm.a
+
+rtlscm.o: $(srcdir)/scm.c $(srcdir)/scm.h $(srcdir)/scmfig.h \
+ $(srcdir)/patchlvl.h scmconfig.h
+ $(CC) $(CFLAGS) $(defines) -c $(FFLAGS) -DRTL $(INITS)init_user_scm\(\) \
+ $(FINALS) $(srcdir)/scm.c
+ mv scm.o rtlscm.o
+
+.PHONY: install installdirs
+install: installdirs \
+ $(bindir)/$(instname) $(mandir)/$(instname).$(manext) \
+ $(libdir)/Init.scm $(libdir)/Transcen.scm $(libdir)/COPYING
+
+installdirs:
+ $(SHELL) ${srcdir}/mkinstalldirs $(bindir) $(infodir) \
+ $(mandir) $(libdir)
+
+$(bindir)/$(instname): instscm
+ $(INSTALL_PROGRAM) instscm $@.new
+# Some systems can't deal with renaming onto a running binary.
+ -rm -f $@.old
+ -mv $@ $@.old
+ mv $@.new $@
+
+$(mandir)/$(instname).$(manext): $(srcdir)/scm.1
+ $(INSTALL_DATA) $(srcdir)/scm.1 $@
+
+$(libdir)/Init.scm: $(srcdir)/Init.scm
+ $(INSTALL_DATA) $(srcdir)/Init.scm $@
+
+$(libdir)/Transcen.scm: $(srcdir)/Transcen.scm
+ $(INSTALL_DATA) $(srcdir)/Transcen.scm $@
+
+$(libdir)/COPYING: $(srcdir)/COPYING
+ $(INSTALL_DATA) $(srcdir)/COPYING $@
+
+.PHONY: tar shar dclshar com zip pubzip
+tar: scm.tar
+shar: scm.shar
+dclshar: scm.com
+com: scm.com
+zip: scm.zip
+scm.tar: temp/scm
+ cd temp; tar chf ../scm.tar scm
+ chmod 664 scm.tar
+scm.shar: temp/scm
+ cd temp; shar scm >../scm.shar
+ chmod 664 scm.shar
+scm.com: temp/scm
+ cd temp; dclshar scm >../scm.com
+ chmod 664 scm.com
+scm.zip: temp/scm
+ cd temp; zip -r ../scm.zip scm
+ chmod 664 scm.zip
+pubzip: temp/scm
+ cd temp; zip -ru ../../pub/scm.zip scm
+ chmod 664 ../pub/scm.zip
+
+temp/scm: $(afiles)
+ -rm -rf temp
+ mkdir temp
+ mkdir temp/scm
+ ln $(afiles) temp/scm
+
+.PHONY: dist tar.Z tar.gz shar.Z
+dist: tar.gz
+tar.Z: scm.tar.Z
+tar.gz: scm.tar.gz
+shar.Z: scm.shar.Z
+scm.tar.Z: scm.tar
+ -rm -f scm.tar.Z
+ compress scm.tar
+ chmod 664 scm.tar.Z
+scm.tar.gz: scm.tar
+ -rm -f scm.tar.gz
+ gzip scm.tar
+ chmod 664 scm.tar.gz
+scm.shar.Z: scm.shar
+ -rm -f scm.shar.Z
+ compress scm.shar
+ chmod 664 scm.shar.Z
+
+.PHONY: pubdiffs distdiffs
+pubdiffs: temp/scm
+ mv temp/scm temp/nscm
+ cd temp;unzip ../../pub/scm.zip
+ -rm -f scm.diffs
+ -diff -c temp/scm temp/nscm > scm.diffs
+ -rm -rf temp
+ ls -l scm.diffs
+distdiffs: temp/scm
+ mv temp/scm temp/nscm
+ cd temp;zcat ../../dist/scm*.tar.gz | tar xvf -
+ -rm -f scm.pat
+ -diff -c temp/scm temp/nscm > scm.pat
+ -rm -rf temp
+ ls -l scm.pat
+
+.PHONY: checks check echeck
+checks: check echeck
+check: ./scm test.scm
+ echo '(test-sc4)(test-cont)(test-inexact)(gc)(exit (length errs))' \
+ | ./scm test.scm
+echeck: ./escm test.scm
+ echo '(test-sc4)(test-cont)(gc)(exit (length errs))' \
+ | ./escm test.scm
+
+.PHONY: lint
+lint: lints
+lints: $(cfiles) $(hfiles)
+ lint $(CFLAGS) $(cfiles) | tee lints
+# lint $(CFLAGS) $(cfiles) | tee lintes
+
+# Seds to help find names not unique in first 8 characters (name8s).
+# for BSD nm format
+# SED_TO_STRIP_NM = sed -e '/.*\.o$$/d' -e 's/.* _//' -e 's/.* T //'
+#old, bad for T [^_] on suns: SED_TO_STRIP_NM=sed -e '/.*\.o$$/d' -e 's/.* _//'
+# For a System V nm where plain C identifiers have _ prepended:
+#SED_TO_STRIP_NM = sed -e '/^_[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g' -e 's/^_//'
+# For a System V nm where plain C identifiers have nothing prepended:
+#SED_TO_STRIP_NM = sed -e '/^[A-Za-z][A-za-z0-9_]*[ |].*|extern|!d' -e 's/|/ /g'
+SED_TO_STRIP_NM = :
+
+.PHONY: name8
+name8: name8s
+name8s: scm
+ nm scm |\
+ $(SED_TO_STRIP_NM) |\
+ sort -u|\
+ awk '{ if (substr(l,1,8)==substr($$1,1,8)) {\
+ if (p) print l;\
+ print $$1;p=0;stat=1\
+ }else p=1;\
+ l=$$1\
+ }END{exit stat}' - |\
+ tee name8s
+
+tagsrcs = $(hfiles) $(cfiles) $(ifiles) $(mfiles) $(vfiles) \
+ MANUAL code.doc README
+TAGS: $(tagsrcs)
+ $(ETAGS) $(tagsrcs)
+tags: $(tagsrcs)
+ $(CTAGS) $(tagsrcs)
+
+.PHONY: clean cleanish realclean
+clean:
+ -rm -f *~ \#* *.o *\# *.orig *.rej a.out core lints tmp*
+ -rm -rf temp hobtemp
+cleanish:
+ -rm -f *~ \#* *\# *.orig *.rej a.out core lints tmp*
+ -rm -rf temp hobtemp
+distclean:
+ -rm -f *~ \#* *.o *\# *.orig *.rej a.out core TAGS lints tmp* \
+ scmconfig.h config.status
+ -rm -rf temp hobtemp
+
+Makefile: config.status $(srcdir)/Makefile.in
+ $(SHELL) config.status
+scmconfig.h: stamp-config ;
+stamp-config: config.status $(srcdir)/scmconfig.h.in
+ $(SHELL) config.status
+ touch stamp-config
+
+configure: configure.in
+ autoconf $(ACFLAGS)
+scmconfig.h.in: configure.in
+ autoheader $(ACFLAGS)
+
+# This tells versions [3.59,3.63) of GNU make not to export all variables.
+.NOEXPORT:
+
+# Automatically generated dependencies will be put at the end of the file.
diff --git a/QUICKREF b/QUICKREF
new file mode 100644
index 0000000..93ca5d4
--- /dev/null
+++ b/QUICKREF
@@ -0,0 +1,201 @@
+;; FILE "Scheme Sigs"
+;; IMPLEMENTS R^4RS Function Signature Synopsis
+;; AUTHOR Kenneth A Dickey
+;; DATE 1992 October 2
+;; LAST UPDATED 1992 October 3
+;; NOTES: Extracted from Amiga Gambit QuickTour file
+
+=== FUNCTION SYNOPSIS ===
+
+Notation:
+ <object> any Scheme data object.
+ <object>* zero or more objects
+ <object>+ one or more objects
+ [<object>] optional object
+ ( <whatever> )... Zero or more occurances of ( <whatever> )
+
+; SYNTAX
+
+ (LAMBDA <name> <exp>+ )
+ (LAMBDA (<name>* ) <exp>+ )
+ (AND <exp>*)
+ (OR <exp>*)
+ (IF <test-exp> <if-true> [<if-false>] )
+ (COND (<test> <exp>* )... [(ELSE <exp>+)] )
+ (CASE <key-exp> ((<datum>+ ) <exp>* )... [(ELSE <exp>+)] )
+ (DEFINE ( <name> <name>* ) <exp>+ )
+ (DEFINE <name> <exp> )
+ (LET [<name>] ( (<vname> <value-exp>)... ) <exp>+ )
+ (LET* ( (<vname> <value-exp>)... ) <exp>+ )
+ (LETREC ( (<vname> <value-exp>)... ) <exp>+ )
+ (BEGIN <expression>+ )
+ (DO ( (<var> <init> <step>)... ) ( <test> <exp>* ) <exp>* )
+ ;; Note also R^4RS syntax, below
+
+
+; IEEE Scheme
+
+ (NOT <object>)
+ (BOOLEAN? <object>)
+
+ (EQ? <obj1> <obj2>)
+ (EQV? <obj1> <obj2>)
+ (EQUAL? <obj1> <obj2>)
+
+ (PAIR? <object>)
+ (CONS <obj1> <obj2>)
+ (CAR <pair>)
+ (CDR <pair>)
+ (SET-CAR! <pair> <object>)
+ (SET-CDR! <pair> <object>)
+ (CAAR <list>) (CADR <list>) (CDAR <list>) (CDDR <list>)
+ (CAAAR <list>) (CAADR <list>) (CADAR <list>) (CADDR <list>)
+ (CDAAR <list>) (CDADR <list>) (CDDAR <list>) (CDDDR <list>)
+ (CAAAAR <list>) (CAAADR <list>) (CAADAR <list>) (CAADDR <list>)
+ (CADAAR <list>) (CADADR <list>) (CADDAR <list>) (CADDDR <list>)
+ (CDAAAR <list>) (CDAADR <list>) (CDADAR <list>) (CDADDR <list>)
+ (CDDAAR <list>) (CDDADR <list>) (CDDDAR <list>) (CDDDDR <list>)
+ (NULL? <object>)
+ (LIST? <object>)
+ (LIST <object>* )
+ (LENGTH <list>)
+ (APPEND <list>+ )
+ (REVERSE <list>)
+ (LIST-REF <list> <index>)
+
+ (MEMQ <object> <list>)
+ (MEMV <object> <list>)
+ (MEMBER <object> <list>)
+
+ (ASSQ <object> <alist>)
+ (ASSV <object> <alist>)
+ (ASSOC <object> <alist>)
+
+ (SYMBOL? <object>) (SYMBOL->STRING <symbol>) (STRING->SYMBOL <string>)
+
+ (NUMBER? <object>)
+ (COMPLEX? <object>)
+ (REAL? <object>)
+ (RATIONAL? <object>)
+ (INTEGER? <object>)
+ (EXACT? <number>) (INEXACT? <number>)
+ (= <number>+ )
+ (< <number>+ ) (> <number>+ )
+ (<= <number>+ ) (>= <number>+ )
+ (ZERO? <number>)
+ (POSITIVE? <number>) (NEGATIVE? <number>)
+ (ODD? <number>) (EVEN? <number>)
+ (MAX <number>+ ) (MIN <number>+ )
+ (+ <number>+ )
+ (* <number>+ )
+ (- <number>+ )
+ (/ <number>+ )
+ (ABS <number>)
+ (QUOTIENT <num1> <num2>) (REMAINDER <num1> <num2>)
+ (MODULO <num1> <num2>)
+ (GCD <number>* ) (LCM <number>* )
+ (NUMERATOR <rational>) (DENOMINATOR <rational>)
+ (FLOOR <number>) (CEILING <number>)
+ (TRUNCATE <number>) (ROUND <number>)
+ (RATIONALIZE <num1> <num2>)
+ (EXP <number>) (LOG <number>)
+ (SIN <number>) (COS <number>) (TAN <number>)
+ (ASIN <number>) (ACOS <number>) (ATAN <number> [<number>])
+ (SQRT <number>)
+ (EXPT <num1> <num2>)
+ (MAKE-RECTANGULAR <num1> <num2>) (MAKE-POLAR <num1> <num2>)
+ (REAL-PART <number>) (IMAG-PART <number>)
+ (MAGNITUDE <number>) (ANGLE <number>)
+ (EXACT->INEXACT <number>) (INEXACT->EXACT <number>)
+ (NUMBER->STRING <number>) (STRING->NUMBER <string>)
+
+ (CHAR? <object>)
+ (CHAR=? <char1> <char2>) (CHAR-CI=? <char1> <char2>)
+ (CHAR<? <char1> <char2>) (CHAR-CI<? <char1> <char2>)
+ (CHAR>? <char1> <char2>) (CHAR-CI>? <char1> <char2>)
+ (CHAR<=? <char1> <char2>) (CHAR-CI<=? <char1> <char2>)
+ (CHAR>=? <char1> <char2>) (CHAR-CI>=? <char1> <char2>)
+ (CHAR-ALPHABETIC? <character>)
+ (CHAR-NUMERIC? <character>)
+ (CHAR-WHITESPACE? <character>)
+ (CHAR-UPPER-CASE? <character>) (CHAR-LOWER-CASE? <character>)
+ (CHAR->INTEGER <character>) (INTEGER->CHAR <integer>)
+ (CHAR-UPCASE <character>) (CHAR-DOWNCASE <character>)
+
+ (STRING? <object>)
+ (MAKE-STRING <length> [<character>] )
+ (STRING <character>+ )
+ (STRING-LENGTH <string>)
+ (STRING-REF <string> <index>)
+ (STRING-SET! <string> <index> <character>)
+ (STRING=? <string1> <string2>) (STRING-CI=? <string1> <string2>)
+ (STRING<? <string1> <string2>) (STRING-CI<? <string1> <string2>)
+ (STRING>? <string1> <string2>) (STRING-CI>? <string1> <string2>)
+ (STRING<=? <string1> <string2>) (STRING-CI<=? <string1> <string2>)
+ (STRING>=? <string1> <string2>) (STRING-CI>=? <string1> <string2>)
+ (SUBSTRING <string> <start-index> <end-index>)
+ (STRING-APPEND <string>+ )
+
+ (VECTOR? <object>)
+ (MAKE-VECTOR <length> [<object>] )
+ (VECTOR <object>* )
+ (VECTOR-LENGTH <vector>)
+ (VECTOR-REF <vector> <index>)
+ (VECTOR-SET! <vector> <index> <object>)
+
+ (PROCEDURE? <object>)
+ (APPLY <procedure> <arg>* <arg-list>)
+ (MAP <procedure> <list>+ )
+ (FOR-EACH <procedure> <list>+ )
+ (CALL-WITH-CURRENT-CONTINUATION <one-argument-procedure>)
+
+ (CALL-WITH-INPUT-FILE <string> <procedure>)
+ (CALL-WITH-OUTPUT-FILE <string> <procedure>)
+ (INPUT-PORT? <object>) (OUTPUT-PORT? <object>)
+ (CURRENT-INPUT-PORT) (CURRENT-OUTPUT-PORT)
+ (OPEN-INPUT-FILE <string>) (OPEN-OUTPUT-FILE <string>)
+ (CLOSE-INPUT-PORT <input-port>) (CLOSE-OUTPUT-PORT <output-port>)
+ (EOF-OBJECT? <object>)
+ (READ [<input-port>] )
+ (READ-CHAR [<input-port>] )
+ (PEEK-CHAR [<input-port>] )
+ (WRITE <object> [<output-port>] )
+ (DISPLAY <object> [<output-port>] )
+ (NEWLINE [<output-port>] )
+ (WRITE-CHAR <character> [<output-port>] )
+
+
+; R4RS Scheme
+
+ (LIST-TAIL <list> <index>)
+ (STRING->LIST <string>)
+ (LIST->STRING <list-of-characters>)
+ (STRING-COPY <string>)
+ (STRING-FILL! <string> <character>)
+ (VECTOR->LIST <vector>)
+ (LIST->VECTOR <list>)
+ (VECTOR-FILL! <vector> <object>)
+ (DELAY <expression>)
+ (FORCE <promise>)
+ (WITH-INPUT-FROM-FILE <string> <thunk>)
+ (WITH-OUTPUT-TO-FILE <string> <thunk>)
+ (CHAR-READY? [<input-port>] )
+ (LOAD <string>)
+ (TRANSCRIPT-ON <string>)
+ (TRANSCRIPT-OFF)
+
+ (DEFINE-SYNTAX <name> <transformer-spec>) -- High-Level macros (only)
+ (LET-SYNTAX ( <syntax-spec>* ) <exp>+ )
+ (LETREC-SYNTAX ( <syntax-spec>* ) <exp>+ )
+
+
+
+=== STANDARDS REFERENCES ===
+
+
+IEEE Standard 1178-1990. "IEEE Standard for the Scheme Programming
+Language", IEEE, New York, 1991, ISBN 1-55937-125-0 [1-800-678-IEEE:
+order # SH14209]. -- now also an ANSI standard.
+
+W. Clinger and J. Rees, eds., "Revised^4 Report on the Algorithmic
+Language Scheme", ACM LISP Pointers IV, 3 (July-September 1991).
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 <jaffer@ai.mit.edu>
+
+ MANIFEST
+
+ `README' is this file. It contains a MANIFEST, INSTALLATION
+ INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE
+ SHOOTING GUIDE.
+ `COPYING' details the LACK OF WARRANTY for scm and the conditions
+ for distributing scm.
+ `scm.1' is the unix style man page in nroff format.
+ `scm.doc' is the text man page generated from scm.1.
+ `QUICKREF' is a Quick Reference card for IEEE and R4RS.
+ `scm.texi' details feature support and enhancements to Scheme and
+ contains a SCHEME BIBLIOGRAPHY.
+ `ChangeLog' documents changes to the scm.
+
+ `r4rstest.scm' is Scheme code which tests conformance with Scheme
+ specifications.
+ `example.scm' is Scheme code from Revised^4 Report on the
+ Algorithmic Language Scheme which uses inexact numbers.
+ `pi.scm' is Scheme code for computing digits of pi [type (pi 100 5)]
+ which can be used to test the performance of scm against
+ compiled C code [cc -o pi pi.c;time pi 100 5].
+ `pi.c' is C code for computing digits of pi.
+ `bench.scm' is Scheme code for computing and recording speed of
+ "pi.scm".
+
+ `Makefile' is for building scmlit using the `make' program.
+ `build.scm' creates a database and program for compiling and linking
+ new SCM executables, libraries, and dlls.
+ `build.bat' invokes build.scm on MS-DOS platforms.
+ `setjump.mar' provides setjmp and longjmp which do not use $unwind
+ utility on VMS.
+ `setjump.s' provides setjmp and longjmp for the Cray YMP.
+
+ `Init.scm' is Scheme initialization code.
+ `Transcen.scm' has Scheme code for inexact builtin procedures.
+ `Link.scm' has Scheme code for compiling and dynamic linking.
+ `scmfig.h' is a C include file containing system dependent definitions.
+ `patchlvl.h is the patchlevel of this release.
+ `continue.c' code for continuations.
+ `continue.h' data types and external functions for continuations.
+ `setjump.h' is an include file dealing with continuations, stacks,
+ and memory allocation.
+ `scm.h' has the data type and external definitions of scm.
+
+ `scm.c' has the top level and interrupt code.
+ `findexec.c' has code to find the executable file.
+ `time.c' has functions dealing with time.
+ `repl.c' has error, read-eval-print loop, read, write and load code.
+ `scl.c' has the code for utility functions which are not part of the
+ IEEE Scheme spec or which are required for non-integer
+ arithmetic.
+ `eval.c' has the evaluator, apply, map, and foreach.
+ `sys.c' has the code for opening and closing files, storage
+ allocation and garbage collection.
+ `rope.c' has C interface functions.
+ `subr.c' has all the rest of functions.
+ `sc2.c' has code for procedures from R2RS and R3RS not in R4RS.
+ `dynl.c' has c code for dynamically loading object files.
+ `unif.c' has code for uniform vectors.
+ `rgx.c' has code for string regular expression match.
+ `crs.c' has code for interactive terminal control.
+ `split.scm' sets up CURSCM (SCM with crs.c) so that input, output,
+ and diagnostic output are each directed to separate windows.
+ `edline.c' Gnu readline input editing
+ (get ftp.sys.toronto.edu:/pub/rc/editline.shar).
+ `Iedline.scm' Gnu readline input editing.
+ `record.c' has code for proposed "Record" user definable datatypes.
+ `gsubr.c' has make_gsubr for arbitrary (< 11) arguments to C functions.
+
+ `ioext.c' has code for system calls in common between PC compilers and unix.
+ `posix.c' has code for posix library interface.
+ `unix.c' has code for non-posix system calls on unix systems.
+ `socket.c' has code for socket interface.
+
+ SLIB
+
+[SLIB] is a portable Scheme library meant to provide compatibility and
+utility functions for all standard Scheme implementations. Although
+SLIB is not *neccessary* to run SCM, I strongly suggest you obtain and
+install it. Bug reports about running SCM without SLIB have very low
+priority. SLIB is available from the same sites as SCM:
+
+ * ftp-swiss.ai.mit.edu:pub/scm/slib2a6.tar.gz
+ * prep.ai.mit.edu:pub/gnu/jacal/slib2a6.tar.gz
+ * ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz
+ * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz
+
+Unpack SLIB (`tar xzf slib2a6.tar.gz' or `unzip -ao slib2a6.zip') in an
+appropriate directory for your system; both `tar' and `unzip' will
+create the directory `slib'.
+
+Then create a file `require.scm' in the SCM "implementation-vicinity"
+(this is the same directory as where the file `Init.scm' is installed).
+`require.scm' should have the contents:
+
+ (define (library-vicinity) "/usr/local/lib/slib/")
+ (load (in-vicinity (library-vicinity) "require"))
+
+where the pathname string `/usr/local/lib/slib/' is to be replaced by
+the pathname into which you installed SLIB. Absolute pathnames are
+recommended here; if you use a relative pathname, SLIB can get confused
+when the working directory is changed (*note chmod: I/O-Extensions.).
+The way to specify a relative pathname is to append it to the
+implementation-vicinity, which is absolute:
+
+ (define library-vicinity
+ (let ((lv (string-append (implementation-vicinity) "../slib/")))
+ (lambda () lv)))
+ (load (in-vicinity (library-vicinity) "require"))
+
+Alternatively, you can set the (shell) environment variable
+`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note
+SCHEME_LIBRARY_PATH: SCM Variables.). If set, the environment variable
+overrides `require.scm'. Again, absolute pathnames are recommended.
+
+ MAKING SCM
+
+ The SCM distribution has "Makefile" which contains rules for making
+"scmlit", a "bare-bones" version of SCM sufficient for running
+`build.scm'. `build.scm' is used to compile (or create scripts to
+compile) full featured versions.
+
+ Makefiles are not portable to the majority of platforms. If
+`Makefile' works for you, good; If not, I don't want to hear about it.
+If you need to compile SCM without build.scm, there are several ways to
+proceed:
+
+ * Use SCM on a different platform to run `build.scm' to create a
+ script to build SCM;
+
+ * Use another implementation of Scheme to run `build.scm' to create a
+ script to build SCM;
+
+ * Create your own script or `Makefile'.
+
+ * Buy a SCM executable from jaffer@ai.mit.edu. See the end of
+ `ANNOUNCE' in the distribution for details.
+
+ * Use scmconfig (From: bos@scrg.cs.tcd.ie):
+
+ Build and install scripts using GNU "autoconf" are available from
+ `scmconfig4e6.tar.gz' in the distribution directories. See
+ `README.unix' in `scmconfig4e6.tar.gz' for further instructions.
+
+ Making SCM with Think C 4.0 or 4.1
+
+Note: These instructions need to be uptdated for scm4e6. If Think C
+can be called using system(), then SCM can be built using build.scm.
+
+ Edit Scmfig.H to set desired options and IMPLINIT.
+ from Yasuaki Honda // honda@csl.SONY.co.jp:
+ Make a project and add source files repl.c, time.c, scm.c, subr.c,
+ sys.c, eval.c, scl.c, sc2.c, and unif.c to it.
+ Add libraries MacTraps, unix, ANSI to the project.
+ The project should be segmented in the following way:
+ ----------
+ repl.c
+ scm.c
+ subr.c
+ sys.c
+ sc2.c
+ unif.c
+ time.c
+ ----------
+ MacTraps
+ unix
+ ----------
+ ANSI
+ ----------
+ eval.c
+ ----------
+ scl.c
+ ----------
+ Choose 'Set Project Type' from 'Project' menu.
+ Choose Application from radio buttons.
+ Set Partition size to 600K. (The default 384K is not enough).
+
+ EDITING SCHEME CODE
+
+Gnu Emacs:
+ Editing of Scheme code is supported by emacs. Buffers holding
+ files ending in .scm are automatically put into scheme-mode.
+
+ If your Emacs can run a process in a buffer you can use the Emacs
+ command `M-x run-scheme' with SCM. However, the run-scheme
+ (`xscheme.el') which comes included with Gnu Emacs 18 will work
+ only with MIT Cscheme. If you are using Emacs 18, get the emacs
+ packages:
+
+ * ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el
+
+ * ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el
+
+ These files are already standard in Emacs 19.
+
+ If your Emacs can not run a process in a buffer, see "under other
+ systems" below.
+
+Epsilon (MS-DOS):
+ There is lisp (and scheme) mode available by use of the package
+ `LISP.E'. It offers several different indentation formats. With
+ this package, buffers holding files ending in `.L', `.LSP', `.S',
+ and `.SCM' (my modification) are automatically put into lisp-mode.
+
+ It is possible to run a process in a buffer under Epsilon. With
+ Epsilon 5.0 the command line options `-e512 -m0' are neccessary to
+ manage RAM properly. It has been reported that when compiling SCM
+ with Turbo C, you need to `#define NOSETBUF' for proper operation
+ in a process buffer with Epsilon 5.0.
+
+ One can also call out to an editor from SCM if RAM is at a
+ premium; See "under other systems" below.
+
+other systems:
+ Define the environment variable `EDITOR' to be the name of the
+ editing program you use. The SCM procedure `(ed arg1 ...)' will
+ invoke your editor and return to SCM when you exit the editor. The
+ following definition is convenient:
+
+ (define (e) (ed "work.scm") (load "work.scm"))
+
+ Typing `(e)' will invoke the editor with the file of interest.
+ After editing, the modified file will be loaded.
+
+ TROUBLE SHOOTING
+
+Reported problems and solutions are grouped under "Compiling",
+"Linking", "Running", and "Testing". If you don't find your problem
+listed here, you can send a bug report to <jaffer@ai.mit.edu>. The
+bug report should include:
+
+ * The version of SCM (printed when SCM is invoked with no arguments).
+
+ * The type of computer you are using.
+
+ * The name and version of your computer's operating system.
+
+ * The values of the environment variables SCM_INIT_PATH and
+ SCHEME_LIBRARY_PATH.
+
+ * The name and version of your C compiler.
+
+ * If you are using an executable from a distribution, the name,
+ vendor, and date of that distribution. In this case,
+ corresponding with the vendor is recommended.
+
+
+ Compiling:
+
+FILE ERROR or WARNING HOW TO FIX
+
+*.c include file not found Correct status of
+ STDC_HEADERS
+
+ fix #include statement
+ or add #define for
+ system type to scmfig.h
+
+scm.c assignment between incompatible types change SIGRETTYPE in scm.c
+
+time.c CLK_TCK redefined incompatablility
+ between <stdlib.h> and
+ <sys/types.h>. remove
+ STDC_HEADERS in scmfig.h
+
+ edit <sys/types.h> to
+ remove incompatability.
+
+sys.c statement not reached ignore
+ constant in conditional expression ignore
+
+sys.c: `???' undeclared, outside of functions #undef STDC_HEADERS
+ in scmfig.h
+
+scl.c syntax error define system type in
+ scmfig.h and scl.c (softtype)
+
+ Linking:
+
+ERROR or WARNING HOW TO FIX
+
+_sin etc. missing. uncomment LIBS in makefile
+
+ Running:
+
+PROBLEM HOW TO FIX
+
+Opening message and then machine Change memory model option
+crashes. to C compiler (or makefile).
+
+ Make sure sizet definition is
+ correct in scmfig.h
+
+ Reduce size of HEAP_SEG_SIZE
+ in setjump.h
+
+Input hangs #define NOSETBUF
+
+ERROR: heap: need larger initial Need to increase the initial
+ heap allocation using
+ -a<kbytes> or INIT_HEAP_SIZE.
+
+ERROR: Could not allocate ... Check sizet definition.
+
+ Get more memory.
+
+ Don't try to run as subproccess
+
+... in scmfig.h and recompile scm Do it and recompile files.
+
+ERROR: Init.scm not found Assign correct IMPLINIT in
+ makefile or scmfig.h or
+ define environment variable
+ SCM_INIT_PATH to be the full
+ pathname of Init.scm (see
+ INSTALLATION instructions).
+
+WARNING: require.scm not found define environment variable
+ SCHEME_LIBRARY_PATH to be the
+ full pathname of the scheme
+ library SLIB or change
+ library-vicinity in Init.scm
+ to point to library or remove.
+ See section SLIB above.
+
+ Make sure library-vicinity has
+ a trailing file separator
+ (like / or \).
+
+ Testing: (load "r4rstest.scm") or (load "pi.scm") (pi 100 5)
+
+Runs some and then machine crashes. See above under machine
+ crashes.
+
+Runs some and then ERROR: ... Remove optimization option
+(after a GC has happened) to C compiler and recompile.
+
+ #define SHORT_ALIGN in scmfig.h
+
+Some symbol names print incorrectly. Change memory model option
+ to C compiler (or makefile).
+
+ Check that HEAP_SEG_SIZE fits
+ within sizet.
+
+ Increase size of HEAP_SEG_SIZE
+ (or INIT_HEAP_SIZE if it is
+ smaller than HEAP_SEG_SIZE).
+
+ERROR: Rogue pointer in Heap. See above under machine
+ crashes.
+
+Newlines don't appear correctly in Check file mode (define OPEN_...
+output files. in Init.scm
+
+Spaces or control characters appear Check character defines in
+in symbol names scmfig.h
+
+Negative numbers turn positive. Check SRS in scmfig.h
+
+VMS: Couldn't unwind stack #define CHEAP_CONTIUATIONS
+VAX: botched longjmp in scmfig.h
+
+Sparc(SUN-4) heap is growing out of control:
+
+ You are experiencing a GC problem peculiar to the Sparc. The
+ problem is that SCM doesn't know how to clear register
+ windows. Every location which is not reused still gets marked
+ at GC time. This causes lots of stuff which should be
+ collected to not be. This will be a problem with any
+ "conservative" GC until we find what instruction will clear
+ the register windows. This problem is exacerbated by using
+ lots of call-with-current-continuations.
diff --git a/README.unix b/README.unix
new file mode 100644
index 0000000..0f9094d
--- /dev/null
+++ b/README.unix
@@ -0,0 +1,182 @@
+This file contains the instructions for building scm4e under Unix
+systems. Scm conforms to Revised^4 Report on the Algorithmic Language
+Scheme and the IEEE P1178 specification. Scm runs under VMS, MS-DOS,
+OS2, MacOS, Amiga, Atari-ST, NOS/VE, Unix and similar systems.
+
+The author of scm can be reached at <jaffer@ai.mit.edu> or
+Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880.
+
+The Unix installation support included in this scmconfig distribution
+has been written by myself, Bryan O'Sullivan <bosullvn@maths.tcd.ie>,
+and is maintained by me. Please direct any problems you have with
+either scm itself or this configuration software to <bug-scm@scrg.cs.tcd.ie>.
+
+NOTE: Before you get started, make sure that you have unpacked this
+ scmconfig distribution into the whatever directory you have
+ unpacked the same version of scm.
+
+Several chunks of this file have been lifted more or less verbatim
+from the standard INSTALL file which comes with most GNU utilities
+these days.
+
+ MANIFEST
+
+ `README.unix' is this file. It contains a MANIFEST, INSTALLATION
+ INSTRUCTIONS, TROUBLESHOOTING, and various other information.
+ `COPYING' details the LACK OF WARRANTY for scmconfig and scm and the
+ conditions for distributing scm and scmconfig.
+ `acconfig-1.5.h' is a temporary fix for a bug in version 1.5 of GNU
+ autoconf. This file should not concern you unless you are
+ familiar with autoconf (you don't need to be).
+ `configure' is an executable shell script which generates
+ `scmconfig.h' and `Makefile'.
+ `configure.in' is a template file used by with autoconf (autoconf is
+ not needed to build scm), which produces the `configure'
+ script.
+ `scmconfig.h.in' is an automatically-generated template file used by
+ configure, which produces `scmconfig.h'.
+ `Makefile.in' is a template file used by configure, which produces
+ `Makefile'.
+
+ INSTALLATION INSTRUCTIONS
+
+To compile this package:
+
+1. In the directory that this file is in, type `./configure'. If
+ you're using `csh' on an old version of System V, you might need
+ to type `sh configure' instead to prevent `csh' from trying to
+ execute `configure' itself.
+
+ You may wish to edit the generated `Makefile' file in order to
+ customise scm to your own preferences. The comments in there
+ should be adequate to let you decide what you want to do.
+ `Makefile' has a reasonable set of defaults for most Unix systems,
+ so you may not have to edit it at all.
+
+[You can skip the rest of this section (down to point 2 below) the
+ first time around.]
+
+ The `configure' shell script attempts to guess correct values for
+ various system-dependent variables used during compilation, and
+ creates the Makefile.
+
+ Running `configure' takes a minute or two. While it is running,
+ it prints some messages that tell what it is doing. If you don't
+ want to see the messages, run `configure' with its standard output
+ redirected to `/dev/null'; for example, `./configure >/dev/null'.
+
+ To compile the package in a different directory from the one
+ containing the source code, you must use a version of `make' that
+ supports the VPATH variable, such as GNU `make'. `cd' to the
+ directory where you want the object files and executables to go
+ and run `configure'. `configure' automatically checks for the
+ source code in the directory that `configure' is in and in `..'.
+ If for some reason `configure' is not in the source code directory
+ that you are configuring, then it will report that it can't find
+ the source code. In that case, run `configure' with the option
+ `--srcdir=DIR', where DIR is the directory that contains the
+ source code.
+
+ See the section titled `INSTALL' below on building scm with
+ different default search paths. By default, when you run `make',
+ scm looks in the source directory for `Init.scm'. The binary
+ which is built when you run `make install' looks in the correct
+ places for files.
+
+ Another `configure' option is useful mainly in `Makefile' rules
+ for updating `config.status' and `Makefile'. The `--no-create'
+ option figures out the configuration for your system and records
+ it in `config.status', without actually configuring the package
+ (creating `Makefile's and perhaps a configuration header file).
+ Later, you can run `./config.status' to actually configure the
+ package. You can also give `config.status' the `--recheck'
+ option, which makes it re-run `configure' with the same arguments
+ you used before. This option is useful if you change `configure'.
+
+ `configure' ignores any other arguments that you give it.
+
+ If your system requires unusual options for compilation or linking
+ that `configure' doesn't know about, you can give `configure'
+ initial values for some variables by setting them in the
+ environment. In Bourne-compatible shells, you can do that on the
+ command line like this:
+ CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure
+
+2. Type `make' to compile the package. If you want, you can override
+ the `make' variables CFLAGS and LDFLAGS like this:
+ make CFLAGS=-O2 LDFLAGS=-s
+
+3. Test scm. This is done in the following way (user input comes
+ after the `bash$' and `>' prompts):
+ bash$ scm
+ SCM version xxx, Copyright (C) 1990, 1991, 1992, 1993 Aubrey Jaffer.
+ SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `(terms)' for details.
+ ;loading ".../Transcen.scm"
+ ;done loading ".../Transcen.scm"
+ ;Evaluation took 230 mSec (0 in gc) 8661 cons work
+ > (load "test.scm")
+ ...
+ > (test-sc4)
+ ...
+ > (test-cont)
+ ...
+ > (test-inexact)
+
+4. You can remove the program binaries and object files from the
+ source directory by typing `make clean'. To also remove the
+ Makefile(s), the header file containing system-dependent definitions
+ (if the package uses one), and `config.status' (all the files that
+ `configure' created), type `make distclean'.
+
+[You can skip this next bit unless you are editing the `configure.in'
+ file, which you should not do unless you are familiar with autoconf.]
+
+ If you are using versions of autoconf before or including 1.5, you
+ should rename `acconfig-1.5.h' to `acconfig.h' before running
+ autoheader, since these distributions do not handle
+ `TIME_WITH_SYS_TIME' correctly.
+
+ INSTALL
+
+Type `make install' to install programs, data files, and
+documentation.
+
+By default, `make install' will install the package's files in
+/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify
+an installation prefix other than /usr/local by giving `configure' the
+option `--prefix=PATH'. Alternately, you can do so by consistently
+giving a value for the `prefix' variable when you run `make', e.g.,
+ make prefix=/usr/gnu
+ make prefix=/usr/gnu install
+
+You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files. If
+you give `configure' the option `--exec-prefix=PATH' or set the `make'
+variable `exec_prefix' to PATH, the package will use PATH as the
+prefix for installing programs and libraries. Data files and
+documentation will still use the regular prefix. Normally, all files
+are installed using the regular prefix.
+
+ TROUBLESHOOTING
+
+If you encounter any problems while building scm, please send
+electronic mail to <bug-scm@scrg.cs.tcd.ie> with a description of the
+problem, and any solution to it you may have found. Some mention of
+the version of Unix you are trying to build scm on, and the versions
+of scm and scmconfig you are using, would be helpful in diagnosing the
+problem.
+
+If you encounter any problems with system include files not being
+found, or attempts being made to read the wrong files, please contact
+<bug-scm@scrg.cs.tcd.ie> with a description of the include files that
+are not being handled correctly; the problem probably lies in the
+autoconf support, and can usually be quickly fixed by manually editing
+`scmconfig.h'.
+
+If you find that scm does not link because it cannot find a
+time-related function, please mail a description of the problem to
+<bug-scm@scrg.cs.tcd.ie>, stating which function(s) can't be found.
+In the mean time, editing the top of `time.c' should provide a fix for
+the problem.
diff --git a/Transcen.scm b/Transcen.scm
new file mode 100644
index 0000000..896f77f
--- /dev/null
+++ b/Transcen.scm
@@ -0,0 +1,133 @@
+;; Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Transcen.scm", Complex trancendental functions for SCM.
+;;; Author: Jerry D. Hedden.
+
+(define compile-allnumbers #t) ;for HOBBIT compiler
+
+(define (exp z)
+ (if (real? z) ($exp z)
+ (make-polar ($exp (real-part z)) (imag-part z))))
+
+(define (log z)
+ (if (and (real? z) (>= z 0))
+ ($log z)
+ (make-rectangular ($log (magnitude z)) (angle z))))
+
+(define (sqrt z)
+ (if (real? z)
+ (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
+ ($sqrt z))
+ (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
+
+(define expt
+ (let ((integer-expt integer-expt))
+ (lambda (z1 z2)
+ (cond ((exact? z2)
+ (integer-expt z1 z2))
+ ((and (real? z2) (real? z1) (>= z1 0))
+ ($expt z1 z2))
+ (else
+ (exp (* z2 (log z1))))))))
+
+(define (sinh z)
+ (if (real? z) ($sinh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sinh x) ($cos y))
+ (* ($cosh x) ($sin y))))))
+(define (cosh z)
+ (if (real? z) ($cosh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cosh x) ($cos y))
+ (* ($sinh x) ($sin y))))))
+(define (tanh z)
+ (if (real? z) ($tanh z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cosh x) ($cos y))))
+ (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
+
+(define (asinh z)
+ (if (real? z) ($asinh z)
+ (log (+ z (sqrt (+ (* z z) 1))))))
+
+(define (acosh z)
+ (if (and (real? z) (>= z 1))
+ ($acosh z)
+ (log (+ z (sqrt (- (* z z) 1))))))
+
+(define (atanh z)
+ (if (and (real? z) (> z -1) (< z 1))
+ ($atanh z)
+ (/ (log (/ (+ 1 z) (- 1 z))) 2)))
+
+(define (sin z)
+ (if (real? z) ($sin z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sin x) ($cosh y))
+ (* ($cos x) ($sinh y))))))
+(define (cos z)
+ (if (real? z) ($cos z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cos x) ($cosh y))
+ (- (* ($sin x) ($sinh y)))))))
+(define (tan z)
+ (if (real? z) ($tan z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cos x) ($cosh y))))
+ (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
+
+(define (asin z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($asin z)
+ (* -i (asinh (* +i z)))))
+
+(define (acos z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($acos z)
+ (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
+
+(define (atan z . y)
+ (if (null? y)
+ (if (real? z) ($atan z)
+ (/ (log (/ (- +i z) (+ +i z))) +2i))
+ ($atan2 z (car y))))
diff --git a/acconfig-1.5.h b/acconfig-1.5.h
new file mode 100644
index 0000000..4f33b04
--- /dev/null
+++ b/acconfig-1.5.h
@@ -0,0 +1,22 @@
+/* acconfig.h
+ This file is in the public domain.
+
+ Descriptive text for the C preprocessor macros that
+ the distributed Autoconf macros can define.
+ No software package will use all of them; autoheader copies the ones
+ your configure.in uses into your configuration header file templates.
+
+ The entries are in sort -df order: alphabetical, case insensitive,
+ ignoring punctuation (such as underscores).
+
+ Leave the following blank line there!! Autoheader needs it. */
+
+
+/* Define if <sys/time.h> and <time.h> do not clash with each other. */
+#undef TIME_WITH_SYS_TIME
+
+
+/* Leave that blank line there!! Autoheader needs it.
+ If you're adding to this file, keep in mind:
+ The entries are in sort -df order: alphabetical, case insensitive,
+ ignoring punctuation (such as underscores). */
diff --git a/bench.scm b/bench.scm
new file mode 100644
index 0000000..acb4a2c
--- /dev/null
+++ b/bench.scm
@@ -0,0 +1,55 @@
+
+(require (in-vicinity (implementation-vicinity) "pi.scm"))
+(require 'transcript)
+(define isqrt
+ (cond ((provided? 'inexact) sqrt)
+ (else (require 'root) integer-sqrt)))
+(define i/
+ (cond ((provided? 'inexact) /)
+ (else quotient)))
+(define around
+ (cond ((provided? 'inexact)
+ (lambda (x)
+ (cond ((>= 3000 (abs x) 3) (inexact->exact (round x)))
+ (else x))))
+ (else identity)))
+
+(define (time-pi digits)
+ (let ((start-time (get-internal-run-time)))
+ (pi digits 4)
+ (i/ (* 1000 (- (get-internal-run-time) start-time))
+ internal-time-units-per-second)))
+
+(define (benchmark . arg)
+ (define file
+ (cond ((null? arg) "bench.log")
+ (else (car arg))))
+ (do ((digits 50 (+ digits digits))
+ (t 0 (time-pi (+ digits digits))))
+ ((> t 3000)
+ (do ((tl '() (cons (time-pi digits) tl))
+ (j 12 (+ -1 j)))
+ ((zero? j)
+ (let* ((avg (i/ (apply + tl) (length tl)))
+ (dev (isqrt (i/ (apply
+ + (map (lambda (x) (* (- x avg) (- x avg)))
+ tl))
+ (length tl)))))
+ (and file (transcript-on file))
+ (for-each display
+ (list digits " digits took " (around avg) " mSec +/- "
+ (around dev) " mSec."))
+ (newline)
+ (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits)))
+ (for-each display
+ (list " That is about " scaled-avg
+ " mSec/k-digit^2 +/- "
+ (around
+ (i/ (* 100 (i/ (* (i/ (* dev 1000) digits)
+ 1000) digits))
+ scaled-avg))
+ "%."))
+ (newline)
+ (and file (transcript-off)))
+ ))))))
+(benchmark)
diff --git a/build.bat b/build.bat
new file mode 100755
index 0000000..723e25e
--- /dev/null
+++ b/build.bat
@@ -0,0 +1 @@
+scm -f %0 -e(bi) build %1 %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/build.scm b/build.scm
new file mode 100755
index 0000000..557a5ab
--- /dev/null
+++ b/build.scm
@@ -0,0 +1,1393 @@
+#!/bin/sh
+type;exec scmlit -f $0 -e"(bi)" build $*
+;;; "build.scm" Build database and program -*-scheme-*-
+;;; Copyright (C) 1994, 1995, 1996 Aubrey Jaffer.
+;;; See the file `COPYING' for terms applying to this program.
+
+(require 'getopt)
+(require 'parameters)
+(require 'database-utilities)
+
+;;;(define build (create-database "buildscm.scm" 'alist-table))
+(define build (create-database #f 'alist-table))
+
+(require 'batch)
+(batch:initialize! build)
+
+(define-tables build
+
+ '(file-formats
+ ((format symbol))
+ ()
+ ((plaintext)
+ (c-source)
+ (c-header)
+ (scheme)
+ (vax-asm)
+ (cray-asm)
+ (makefile)
+ (MS-DOS-batch)
+ (nroff)
+ (texinfo)))
+
+ '(file-categories
+ ((category symbol))
+ ((documentation string))
+ ((documentation "Documentation file (or source for)")
+ (required "File required for building executable SCM")
+ (optional "File required for some feature")
+ (linkable "File whose object can be dynamically linked")
+ (test "File to test SCM")
+ (none "No files")))
+
+ '(build-whats
+ ((name symbol))
+ ((class file-categories)
+ (c-proc symbol)
+ (o-proc symbol)
+ (spec expression)
+ (documentation string))
+ ((exe required compile-c-files link-c-program #f
+ "executable program")
+ (lib required compile-c-files make-archive ((define "RTL"))
+ "library module")
+ (dlls linkable compile-dll-c-files make-dll-archive ((define "RTL"))
+ "archived dynamically linked library object files")
+ (dll none compile-dll-c-files make-nothing #f
+ "dynamically linked library object file")))
+
+ '(manifest
+ ((file string))
+ ((format file-formats)
+ (category file-categories)
+ (documentation string))
+ (("README" plaintext documentation "contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE.")
+ ("COPYING" plaintext documentation "details the LACK OF WARRANTY for SCM and the conditions for distributing SCM.")
+ ("scm.1" nroff documentation "unix style man page.")
+ ("scm.doc" plaintext documentation "man page generated from scm.1.")
+ ("QUICKREF" plaintext documentation "Quick Reference card for R4RS and IEEE Scheme.")
+ ("scm.texi" Texinfo documentation "SCM installation and use.")
+ ("ChangeLog" plaintext documentation "changes to SCM.")
+ ("r4rstest.scm" Scheme test "tests conformance with Scheme specifications.")
+ ("example.scm" Scheme test "example from R4RS which uses inexact numbers.")
+ ("pi.scm" Scheme test "computes digits of pi [type (pi 100 5)]. Test performance against pi.c.")
+ ("pi.c" c-source test "computes digits of pi [cc -o pi pi.c;time pi 100 5].")
+ ("bench.scm" Scheme test "computes and records performance statistics of pi.scm.")
+ ("Makefile" Makefile required "builds SCMLIT using the `make' program.")
+ ("build.scm" Scheme required "database for compiling and linking new SCM programs.")
+ ("build.bat" MS-DOS-batch optional "invokes build.scm for MS-DOS")
+ ("setjump.mar" Vax-asm optional "provides setjmp and longjmp which do not use $unwind utility on VMS.")
+ ("setjump.s" Cray-asm optional "provides setjmp and longjmp for the Cray YMP.")
+ ("Init.scm" Scheme required "Scheme initialization.")
+ ("Transcen.scm" Scheme required "inexact builtin procedures.")
+ ("Link.scm" Scheme required "compiles and dynamically links.")
+ ("scmfig.h" c-header required "contains system dependent definitions.")
+ ("patchlvl.h" c-header required "patchlevel of this release.")
+ ("setjump.h" c-header required "continuations, stacks, and memory allocation.")
+ ("continue.h" c-header required "continuations.")
+ ("continue.c" c-source required "continuations.")
+ ("scm.h" c-header required "data type and external definitions of SCM.")
+ ("scm.c" c-source required "top level, interrupts, and non-IEEE utility functions.")
+ ("findexec.c" c-source required "find the executable file function.")
+ ("time.c" c-source required "functions dealing with time.")
+ ("repl.c" c-source required "error, read-eval-print loop, read, write and load.")
+ ("scl.c" c-source required "inexact arithmetic")
+ ("eval.c" c-source required "evaluator, apply, map, and foreach.")
+ ("sys.c" c-source required "call-with-current-continuation, opening and closing files, storage allocation and garbage collection.")
+ ("subr.c" c-source required "the rest of IEEE functions.")
+ ("unif.c" c-source required "uniform vectors.")
+ ("rope.c" c-source required "C interface functions.")
+ ("ramap.c" c-source optional "array mapping")
+ ("dynl.c" c-source optional "dynamically load object files.")
+ ("sc2.c" c-source linkable "procedures from R2RS and R3RS not in R4RS.")
+ ("rgx.c" c-source linkable "string regular expression match.")
+ ("crs.c" c-source linkable "interactive terminal control.")
+ ("split.scm" Scheme test "example use of crs.c. Input, output, and diagnostic output directed to separate windows.")
+ ("edline.c" c-source linkable "Gnu readline input editing (get ftp.sys.toronto.edu:/pub/rc/editline.shar).")
+ ("Iedline.scm" Scheme optional "Gnu readline input editing.")
+ ("record.c" c-source linkable "proposed `Record' user definable datatypes.")
+ ("gsubr.c" c-source linkable "make_gsubr for arbitrary (< 11) arguments to C functions.")
+ ("ioext.c" c-source linkable "system calls in common between PC compilers and unix.")
+ ("posix.c" c-source linkable "posix library interface.")
+ ("unix.c" c-source linkable "non-posix system calls on unix systems.")
+ ("socket.c" c-source linkable "BSD socket interface.")
+ ("pre-crt0.c" c-source optional "loaded before crt0.o on machines which do not remap part of the data space into text space in unexec.")
+ ("ecrt0.c" c-source optional "standard Vax 4.2 Unix crt0.c cannot be used because it makes `envron' an initialized variable.")
+ ("gmalloc.c" c-source optional "Gnu malloc().")
+ ("unexec.c" c-source optional "Convert a running program into an a.out file.")
+ ("unexelf.c" c-source optional "Convert a running ELF program into an a.out file.")
+ )))
+
+(for-each (build 'add-domain)
+ '((optstring #f (lambda (x) (or (not x) (string? x))) string #f)
+ (filename #f #f string #f)
+ (build-whats #f #f symbol #f)))
+
+(define-tables build
+
+ '(processor-family
+ ((family atom))
+ ((also-runs processor-family))
+ ((*unknown* #f)
+ (8086 #f)
+ (acorn #f)
+ (cray #f)
+ (hp-risc #f)
+ (i386 8086)
+ (m68000 #f)
+ (m68030 m68000)
+ (mips #f)
+ (nos/ve #f)
+ (pdp-10 #f)
+ (pdp-11 #f)
+ (pdp-8 #f)
+ (powerpc #f)
+ (pyramid #f)
+ (sequent #f)
+ (sparc #f)
+ (tahoe #f)
+ (vax pdp-11)
+ ))
+
+ '(platform
+ ((name symbol))
+ ((processor processor-family)
+ (operating-system operating-system)
+ (compiler symbol))
+ ((*unknown* *unknown* unix *unknown*)
+ (acorn-unixlib acorn *unknown* *unknown*)
+ (aix powerpc aix *unknown*)
+ (amiga-aztec m68000 amiga aztec)
+ (amiga-dice-c m68000 amiga dice-c)
+ (amiga-sas/c-5.10 m68000 amiga sas/c)
+ (atari-st-gcc m68000 atari.st gcc)
+ (atari-st-turbo-c m68000 atari.st turbo-c)
+ (borland-c-3.1 8086 ms-dos borland-c)
+ (djgpp i386 ms-dos gcc)
+ (gcc *unknown* unix gcc)
+ (highc.31 i386 ms-dos highc)
+ (hp-ux hp-risc hp-ux *unknown*)
+ (linux-aout i386 linux gcc)
+ (linux i386 linux gcc)
+ (microsoft-c 8086 ms-dos microsoft-c)
+ (microsoft-c-nt i386 ms-dos microsoft-c)
+ (microsoft-quick-c 8086 ms-dos microsoft-quick-c)
+ (ms-dos 8086 ms-dos *unknown*)
+ (os/2-cset i386 os/2 C-Set++)
+ (os/2-emx i386 os/2 gcc)
+ (sun sparc sun-os *unknown*)
+ (svr4 *unknown* unix *unknown*)
+ (turbo-c-2 8086 ms-dos turbo-c)
+ (unicos cray unicos *unknown*)
+ (unix *unknown* unix *unknown*)
+ (vms vax vms *unknown*)
+ (vms-gcc vax vms gcc)
+ (watcom-9.0 i386 ms-dos watcom)
+ ))
+
+ '(C-libraries
+ ((library symbol)
+ (platform platform))
+ ((compiler-flags string)
+ (link-lib-flag string)
+ (lib-path optstring)
+ (supress-files expression))
+
+ ((m *unknown* "" "-lm" "/usr/lib/libm.a" ())
+ (c *unknown* "" "-lc" "/usr/lib/libc.a" ())
+ (regex *unknown* "" "-lrgx" "/usr/lib/librgx.a" ())
+ (curses *unknown* "" "-lcurses" "/usr/lib/libcurses.a" ())
+ (graphics *unknown* "-I/usr/X11/include -DX11" "-lX11"
+ "/usr/X11/lib/libX11.sa" ())
+ (editline *unknown* "" "-ledit" "/usr/lib/libedit.a" ())
+ (termcap *unknown* "" "-ltermcap" "/usr/lib/libtermcap.a" ())
+ (debug *unknown* "-g" "-g" #f ())
+
+ (m linux-aout "" "-lm" "/usr/lib/libm.sa" ())
+ (c linux-aout "" "-lc" "/usr/lib/libc.sa" ())
+ (dlll linux-aout "-DDLD -DDLD_DYNCM" "-ldld" #f ("findexec.c"))
+ (regex linux-aout "" "" "" ())
+ (curses linux-aout "-I/usr/include/ncurses" "-lncurses"
+ "/usr/lib/libncurses.a" ())
+ (nostart linux-aout "" "-nostartfiles" #f ("ecrt0.c"))
+ (dump linux-aout "" "/usr/lib/crt0.o" #f ("unexelf.c"))
+
+ (m linux "" "-lm" "/lib/libm.so" ())
+ (c linux "" "-lc" "/lib/libc.so" ())
+ (dlll linux "-DSUN_DL" "-ldl" #f ())
+ (graphics linux "-I/usr/include/X11 -DX11" "-L/usr/X11R6/lib -lX11"
+ "/usr/X11R6/lib/libX11.so" ())
+ (curses linux "" "-lcurses" "/lib/libncurses.so" ())
+ (nostart linux "" "" #f ("pre-crt0.c" "ecrt0.c"))
+ (dump linux "" "" #f ("unexec.c"))
+
+ (m acorn-unixlib "" "" #f ())
+
+ (m amiga-dice-c "" "-lm" #f ())
+ (m amiga-SAS/C-5.10 "" "lcmieee.lib" #f ())
+ (c amiga-SAS/C-5.10 "" "lc.lib" #f ())
+
+ (m vms-gcc "" "" #f ())
+ (m vms "" "" #f ())
+
+ (m atari-st-gcc "" "-lpml" #f ())
+ (m atari-st-turbo-c "" "" #f ())
+
+ (m sun "" "-lm" #f ())
+ (dlll sun "-DSUN_DL" "-ldl" #f ())
+ (nostart sun "" "-e __start -nostartfiles -static" #f ("pre-crt0.c"))
+ (dump sun "" "" #f ("unexec.c"))
+
+ (m hp-ux "" "-lm" #f ())
+ (dlll hp-ux "-DHAVE_DYNL" "-Wl,-E -ldld" #f ())
+ (graphics hp-ux "-DX11" "-lX" "/usr/lib/X11R5/libX11.sl" ())
+
+ (c djgpp "" "-lc" #f ("findexec.c"))
+ (curses djgpp "-I/djgpp/contrib/pdcurses/include/"
+ "-L/djgpp/contrib/pdcurses/lib/ -lcurses"
+ "\\djgpp\\contrib\\pdcurses\\lib\\libcurse.a" ())
+ (nostart djgpp "" "-nostartfiles" #f ("ecrt0.c"))
+ (dump djgpp "" "c:/djgpp/lib/crt0.o" #f ("unexelf.c"))
+
+ (c Microsoft-C "" "" #f ("findexec.c"))
+ (m Microsoft-C "" "" #f ())
+ (c Microsoft-C-nt "" "" #f ("findexec.c"))
+ (m Microsoft-C-nt "" "" #f ())
+ (c Microsoft-Quick-C "" "" #f ("findexec.c"))
+ (m Microsoft-Quick-C "" "" #f ())
+
+ (c Turbo-C-2 "" "" #f ("findexec.c"))
+ (m Turbo-C-2 "" "" #f ())
+ (graphics Turbo-C-2 "" "graphics.lib" #f ())
+
+ (c Borland-C-3.1 "" "" #f ("findexec.c"))
+ (m Borland-C-3.1 "" "" #f ())
+ (graphics Borland-C-3.1 "" "graphics.lib" #f ())
+ (windows Borland-C-3.1 "-N -W" "-W" #f ())
+
+ (c highc.31 "" "" #f ("findexec.c"))
+ (m highc.31 "" "" #f ())
+ (windows highc.31 "-Hwin" "-Hwin" #f ())
+ ))
+
+ '(compile-commands
+ ((name symbol)
+ (platform platform))
+ ((procedure expression))
+
+ ((compile-c-files Borland-C-3.1
+ (lambda (files parms)
+ (define rsp-name "temp.rsp")
+ (apply batch:lines->file parms rsp-name files)
+ (batch:system parms
+ "bcc" "-d" "-O" "-Z" "-G" "-w-pro" "-ml" "-c"
+ (if (member '(define "FLOATS" #t)
+ (c-defines parms))
+ "" "-f-")
+ (c-includes parms)
+ (c-flags parms)
+ (string-append "@" rsp-name))
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Borland-C-3.1
+ (lambda (oname objects libs parms)
+ (define lnk-name (string-append oname ".lnk"))
+ (apply batch:lines->file parms
+ lnk-name
+ (append libs objects))
+ (batch:system parms "bcc"
+ (string-append "-e" oname)
+ "-ml"
+ (string-append "@" lnk-name))
+ (string-append oname ".exe")))
+
+ (compile-c-files Turbo-C-2
+ (lambda (files parms)
+ (batch:system parms
+ "tcc" "-c" "-d" "-O" "-Z" "-G" "-ml" "-c"
+ "-Ic:\\turboc\\include"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Turbo-C-2
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects) ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (if (not (string-ci=? exe oexe))
+ (batch:delete-file parms oexe))
+ (batch:system parms
+ "tcc" "-Lc:\\turboc\\lib" libs objects)
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+
+ (compile-c-files Microsoft-C
+ (lambda (files parms)
+ (batch:system parms
+ "cl" "-c" "Oxp" "-AH"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Microsoft-C
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects) ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (if (not (string-ci=? exe oexe))
+ (batch:delete-file parms oexe))
+ (batch:system parms
+ "link" "/noe" "/ST:40000"
+ (apply string-join "+"
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+ (compile-c-files Microsoft-C-nt
+ (lambda (files parms)
+ (batch:system parms
+ "cl" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Microsoft-C-nt
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects) ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (if (not (string-ci=? exe oexe))
+ (batch:delete-file parms oexe))
+ (batch:system parms
+ "link"
+ (apply string-join " "
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+
+ (compile-c-files Microsoft-Quick-C
+ (lambda (files parms)
+ (batch:system parms
+ "qcl" "/AH" "/W1" "/Ze" "/O" "/Ot" "/DNDEBUG"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Microsoft-Quick-C
+ (lambda (oname objects libs parms)
+ (define crf-name (string-append oname ".crf"))
+ (apply batch:lines->file parms
+ crf-name
+ `(,@(map (lambda (f) (string-append f " +"))
+ objects)
+ ""
+ ,(string-append oname ".exe")
+ ,(apply string-join " " libs)
+ ";"))
+ (batch:system parms
+ "qlink"
+ "/CP:0xffff" "/NOI" "/SE:0x80" "/ST:0x9c40"
+ crf-name)
+ (string-append oname ".exe")))
+
+ (compile-c-files Watcom-9.0
+ (lambda (files parms)
+ (batch:system parms
+ "wcc386p" "/mf" "/d2" "/ze" "/oxt" "/3s"
+ "/zq" "/w3"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program Watcom-9.0
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects)
+ ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (if (not (string-ci=? exe oexe))
+ (batch:delete-file parms oexe))
+ (batch:system parms
+ "wlinkp" "option" "quiet" "option"
+ "stack=40000" "FILE"
+ (apply string-join ","
+ (map (lambda (o)
+ (replace-suffix o ".obj" ""))
+ objects))
+ libs)
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+ (compile-c-files highc.31
+ (lambda (files parms)
+ (define hcc-name "temp.hcc")
+ (apply batch:lines->file parms hcc-name files)
+ (batch:system parms
+ "\\hi_c\\hc386.31\\bin\\hc386"
+ (c-includes parms)
+ (c-flags parms)
+ "-c" (string-append "@" hcc-name))
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program highc.31
+ (lambda (oname objects libs parms)
+ (let ((oexe (string-append oname ".exe")))
+ (define lnk-name (string-append oname ".lnk"))
+ (apply batch:lines->file parms
+ lnk-name (append libs objects))
+ (batch:system parms
+ "\\hi_c\\hc386.31\\bin\\hc386" "-o" oname
+ (string-append "@" lnk-name))
+ (batch:system parms
+ "bind386" "/hi_c/pharlap.51/run386b.exe" oname
+ "-exe" oexe)
+ oexe)))
+
+ (compile-c-files djgpp
+ (lambda (files parms)
+ (batch:apply-chop-to-fit
+ batch:try-system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (c-includes parms) (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program djgpp
+ (lambda (oname objects libs parms)
+ (let ((exe (string-append oname ".exe")))
+ (or
+ (batch:try-system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "c:/djgpp/lib/crt0.o")
+ (append objects libs)))
+ (let ((arname (string-append oname ".a")))
+ (batch:delete-file parms arname)
+ (batch:apply-chop-to-fit
+ batch:try-system parms
+ "ar" "r" arname objects)
+ (batch:system
+ parms "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "c:/djgpp/lib/crt0.o")
+ (cons arname libs))))
+ (slib:error 'build "couldn't build archive"))
+ (batch:system parms "strip" oname)
+ (batch:delete-file parms exe)
+ (batch:system parms
+ "coff2exe" "-s"
+ "c:\\djgpp\\bin\\go32.exe"
+ oname)
+ exe)))
+
+ (compile-c-files os/2-emx
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-O" "-m386" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program os/2-emx
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "gcc" "-o" (string-append oname ".exe")
+ objects libs)
+ (string-append oname ".exe")))
+
+ (compile-c-files os/2-cset
+ (lambda (files parms)
+ (batch:system parms
+ "icc.exe" "/Gd-" "/Ge+" "/Gm+" "/Q" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program os/2-cset
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "link386.exe" objects libs
+ (string-append "," oname ".exe,,,;"))
+ (string-append oname ".exe")))
+
+ (compile-c-files HP-UX
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "+O1" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (compile-dll-c-files HP-UX
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "+O1" "-Wl,-E" "+z" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (for-each
+ (lambda (fname)
+ (batch:rename-file parms
+ (string-append fname ".sl")
+ (string-append fname ".sl~"))
+ (batch:system parms
+ "ld" "-b" "-o"
+ (string-append fname ".sl")
+ (string-append fname ".o")))
+ (replace-suffix files ".c" ""))
+ (replace-suffix files ".c" ".sl")))
+; (make-dll-archive HP-UX
+; (lambda (oname objects libs parms)
+; (batch:system parms
+; "ld" "-b" "-o" (string-append oname ".sl")
+; objects)
+; (string-append oname ".sl")))
+
+ (make-dll-archive sun
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "ld" "-assert" "pure-text" "-o"
+ (string-append oname ".so.1.0")
+ objects)
+ (string-append oname ".so.1.0")))
+
+ (compile-c-files linux-aout
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (compile-dll-c-files linux-aout
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+;;; (make-dll-archive linux-aout
+;;; (lambda (oname objects libs parms) #t
+;;; oname))
+
+ (compile-c-files linux
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-O2" "-c" (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (compile-dll-c-files linux
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-O2" "-fpic" "-c" (c-includes parms)
+ (c-flags parms)
+ files)
+ (let* ((platform (car (parameter-list-ref
+ parms 'platform)))
+ (ld-opts
+ (map (lambda (l)
+ (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib))))
+ (for-each
+ (lambda (fname)
+ (batch:system parms
+ "gcc" "-shared" "-o"
+ (string-append fname ".so")
+ (string-append fname ".o")
+ ld-opts))
+ (replace-suffix files ".c" "")))
+ (replace-suffix files ".c" ".so")))
+ (make-dll-archive linux
+ (lambda (oname objects libs parms)
+ (let ((platform (car (parameter-list-ref
+ parms 'platform))))
+ (batch:system
+ parms
+ "gcc" "-shared" "-o"
+ (string-append oname ".so")
+ objects
+ (map (lambda (l) (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib))))
+ (string-append oname ".so")))
+ (link-c-program linux
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "gcc" "-rdynamic" "-o" oname
+ (must-be-first
+ '("pre-crt0.o" "ecrt0.o" "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname))
+
+ (compile-c-files Unicos
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-hvector2" "-hscalar2" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program Unicos
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "cc" "setjump.o" "-o" oname objects libs)
+ oname))
+
+ (compile-c-files gcc
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-Wall" "-O2" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+
+ (link-c-program gcc
+ (lambda (oname objects libs parms)
+ (batch:rename-file parms
+ oname (string-append oname "~"))
+ (batch:system parms
+ "gcc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname))
+
+ (compile-c-files svr4
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-O" "-DSVR4" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+
+ (compile-c-files aix
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-O" "-Dunix" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program aix
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "cc" "-lansi" "-o" oname objects libs)
+ oname))
+
+ (compile-c-files amiga-aztec
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-dAMIGA"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program amiga-aztec
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "cc" "-o" oname objects libs "-lma")
+ oname))
+
+ (compile-c-files amiga-SAS/C-5.10
+ (lambda (files parms)
+ (batch:system parms
+ "lc" "-d3" "-M" "-fi" "-O"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (batch:system parms "blink with link.amiga NODEBUG")
+ (replace-suffix files ".c" ".o")))
+ (link-c-program amiga-SAS/C-5.10
+ (lambda (oname objects libs parms)
+ (define lnk-name "link.amiga")
+ (apply batch:lines->file parms
+ lnk-name
+ (apply string-join "+" ">FROM LIB:c.o"
+ (map object->string objects))
+ (string-append
+ "TO " (object->string (string-append "/" oname)))
+ (append
+ (cond
+ ((pair? libs)
+ (cons (string-append "LIB LIB:" (car libs))
+ (map (lambda (s)
+ (string-append " LIB:" s))
+ (cdr libs))))
+ (else '()))
+ '("VERBOSE" "SC" "SD")))
+ oname))
+
+ (compile-c-files amiga-dice-c
+ (lambda (files parms)
+ (batch:system parms
+ "dcc" "-r" "-gs" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files "-o" (replace-suffix files ".c" ".o"))
+ (replace-suffix files ".c" ".o")))
+ (link-c-program amiga-dice-c
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "dcc" "-r" "-gs" "-o" oname objects libs)
+ oname))
+
+ (compile-c-files atari-st-gcc
+ (lambda (files parms)
+ (batch:system parms
+ "gcc" "-v" "-O" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program atari-st-gcc
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "gcc" "-v" "-o" (string-append oname ".ttp")
+ objects libs)
+ (string-append oname ".ttp")))
+
+ (compile-c-files atari-st-turbo-c
+ (lambda (files parms)
+ (batch:system parms
+ "tcc" "-P" "-W-" "-Datarist"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program atari-st-turbo-c
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "tlink" "-o" (string-append oname ".ttp")
+ objects libs "mintlib.lib" "osbind.lib"
+ "pcstdlib.lib" "pcfltlib.lib")
+ (string-append oname ".ttp")))
+
+ (compile-c-files acorn-unixlib
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-c" "-depend" "!Depend" "-IUnixLib:"
+ "-pcc" "-Dunix" "-DSVR3" "-DARM_ULIB"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program acorn-unixlib
+ (lambda (oname objects libs parms)
+ (batch:system parms
+ "link" "-o" oname objects libs
+ ":5.$.dev.gcc.unixlib36d.clib.o.unixlib")
+ (batch:system parms
+ "squeeze" oname)
+ oname))
+
+ (compile-c-files vms
+ (lambda (files parms)
+ (batch:system parms
+ "cc"
+ (c-includes parms)
+ (c-flags parms)
+ (replace-suffix files ".c" ""))
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program vms
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects)
+ ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (batch:system parms
+ "macro" "setjump")
+ (batch:system parms
+ "link"
+ (apply string-join ","
+ (append (map (lambda (f)
+ (replace-suffix f ".obj" ""))
+ objects)
+ '("setjump" "sys$input/opt\n ")))
+ (apply string-join
+ "," (append (remove "" libs)
+ '("sys$share:vaxcrtl/share"))))
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+
+ (compile-c-files vms-gcc
+ (lambda (files parms)
+ (batch:system parms
+ "gcc"
+ (c-includes parms)
+ (c-flags parms)
+ (replace-suffix files ".c" ""))
+ (replace-suffix files ".c" ".obj")))
+ (link-c-program vms-gcc
+ (lambda (oname objects libs parms)
+ (let ((exe (replace-suffix (car objects)
+ ".obj" ".exe"))
+ (oexe (string-append oname ".exe")))
+ (batch:system parms
+ "macro" "setjump")
+ (batch:system parms
+ "link"
+ (apply string-join ","
+ (append objects
+ '("setjump.obj"
+ "sys$input/opt\n ")))
+ (apply string-join
+ "," (append (remove "" libs)
+ '("gnu_cc:[000000]gcclib/lib"
+ "sys$share:vaxcrtl/share"))))
+ (if (not (string-ci=? exe oexe))
+ (batch:rename-file parms exe oexe))
+ oexe)))
+
+ (compile-c-files *unknown*
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-O" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (link-c-program *unknown*
+ (lambda (oname objects libs parms)
+ (batch:rename-file parms
+ oname (string-append oname "~"))
+ (batch:system parms
+ "cc" "-o" oname
+ (must-be-first
+ '("-nostartfiles"
+ "pre-crt0.o" "ecrt0.o"
+ "/usr/lib/crt0.o")
+ (append objects libs)))
+ oname))
+ (make-archive *unknown*
+ (lambda (oname objects libs parms)
+ (let ((aname (string-append oname ".a")))
+ (batch:system parms
+ "ar rc" aname objects)
+ (batch:system parms
+ "ranlib" aname)
+ aname)))
+ (compile-dll-c-files *unknown*
+ (lambda (files parms)
+ (batch:system parms
+ "cc" "-O" "-c"
+ (c-includes parms)
+ (c-flags parms)
+ files)
+ (replace-suffix files ".c" ".o")))
+ (make-dll-archive *unknown*
+ (lambda (oname objects libs parms)
+ (let ((aname (string-append oname ".a")))
+ (batch:system parms
+ "ar rc" aname objects)
+ (batch:system parms
+ "ranlib" aname)
+ aname)))
+ (make-nothing *unknown*
+ (lambda (oname objects libs parms)
+ (if (= 1 (length objects)) (car objects)
+ objects)))
+ ))
+
+ '(features
+ ((name symbol))
+ ((spec expression)
+ (documentation string))
+ ((lit () "Light - no features")
+ (none () "No features")
+
+ (cautious ((define "CAUTIOUS"))
+ "\
+Normally, the number of arguments arguments to interpreted closures
+ (from LAMBDA) are checked if the function part of a form is not a
+symbol or only the first time the form is executed if the function
+part is a symbol. defining RECKLESS disables any checking. If you
+want to have SCM always check the number of arguments to interpreted
+closures #define CAUTIOUS.")
+
+ (careful-interrupt-masking ((define "CAREFUL_INTS"))
+ "\
+Define CAREFUL_INTS for extra checking of interrupt masking. This is
+for debugging C code in sys.c and repl.c.")
+
+ (debug ((c-lib debug)
+ (features cautious careful-interrupt-masking stack-limit))
+ "Debugging")
+
+ (reckless ((define "RECKLESS"))
+ "\
+If your scheme code runs without any errors you can disable almost all
+error checking by compiling all files with RECKLESS.")
+
+ (stack-limit ((define ("STACK_LIMIT" "(HEAP_SEG_SIZE/2)")))
+ "\
+Define STACK_LIMIT to enable checking for stack overflow. Define
+value of STACK_LIMIT to be the size to which SCM should allow the
+stack to grow. STACK_LIMIT should be less than the maximum size the
+hardware can support, as not every routine checks the stack.")
+
+ (bignums ((define "BIGNUMS"))
+ "\
+Large precision integers.")
+
+ (arrays ((define "ARRAYS"))
+ "\
+Define ARRAYS if you want arrays, uniform-arrays and uniform-vectors.")
+
+ (array-for-each ((c-file "ramap.c") (init "init_ramap"))
+ "\
+array-map! and array-for-each (ARRAYS must also be defined).")
+
+ (inexact ((define "FLOATS") (c-lib m))
+ "\
+Define FLOATS if you want floating point numbers.")
+
+ (engineering-notation ((define "ENGNOT"))
+ "\
+Define ENGNOT if you want floats to display in engineering notation
+ (exponents always multiples of 3) instead of scientific notation.")
+
+ (single-precision-only ((define "SINGLESONLY"))
+ "\
+Define SINGLESONLY if you want all inexact real numbers to be single
+precision. This only has an effect if SINGLES is also defined (which
+is the default). This does not affect complex numbers.")
+
+ (sicp ((define "SICP"))
+ "\
+Define SICP if you want to run code from:
+
+ H. Abelson, G. J. Sussman, and J. Sussman,
+ Structure and Interpretation of Computer Programs,
+ The MIT Press, Cambridge, Massachusetts, USA
+
+ (eq? '() '#f) is the major difference.")
+
+ (rev2-procedures ((c-file "sc2.c") (init "init_sc2"))
+ "\
+These procedures were specified in the `Revised^2 Report on Scheme'
+but not in `R4RS'.")
+
+ (record ((c-file "record.c") (init "init_record"))
+ "\
+The Record package provides a facility for user to define their own
+record data types. See SLIB for documentation.")
+
+ (compiled-closure ((define "CCLO"))
+ "\
+Define CCLO if you want to use compiled closures.")
+
+ (generalized-c-arguments ((c-file "gsubr.c") (init "init_gsubr"))
+ "\
+make_gsubr for arbitrary (< 11) arguments to C functions.")
+
+ (tick-interrupts ((define "TICKS"))
+ "\
+Define TICKS if you want the ticks and ticks-interrupt functions.")
+
+ (i/o-extensions ((c-file "ioext.c") (init "init_ioext"))
+ "\
+Commonly available I/O extensions: `Exec', line I/O, file positioning,
+file delete and rename, and directory functions.")
+
+ (turtlegr
+ ((c-file "turtlegr.c") (c-lib graphics) (features inexact)
+ (init "init_turtlegr"))
+ "\
+`Turtle' graphics calls for both Borland-C and X11.")
+
+ (curses ((c-file "crs.c") (c-lib curses) (init "init_crs"))
+ "\
+`Curses' screen management package.")
+
+ (edit-line
+ ((c-file "edline.c") (c-lib termcap editline) (compiled-init "init_edline"))
+ "\
+interface to the editline or GNU readline library")
+
+ (regex ((c-file "rgx.c") (c-lib regex) (init "init_rgx"))
+ "\
+String regular expression matching.")
+
+ (socket ((c-file "socket.c") (init "init_socket"))
+ "\
+BSD socket interface.")
+
+ (posix ((c-file "posix.c") (init "init_posix"))
+ "\
+Posix functions available on all `Unix-like' systems. fork and
+process functions, user and group IDs, file permissions, and `link'.")
+
+ (unix ((c-file "unix.c") (init "init_unix"))
+ "\
+Those unix features which have not made it into the Posix specs: nice,
+acct, lstat, readlink, symlink, mknod and sync.")
+
+ (windows ((c-lib windows)) ; (define "NON_PREEMPTIVE")
+ "\
+Microsoft Windows executable.")
+
+ (dynamic-linking ((c-file "dynl.c") (c-lib dlll))
+ "\
+Load compiled files while running.")
+
+ (dump ((define "CAN_DUMP")
+ (c-lib dump)
+ (c-lib nostart)
+ (c-file "unexec.c")
+ (c-file "unexelf.c")
+ (c-file "gmalloc.c")
+ (c-file "ecrt0.c")
+ (c-file "pre-crt0.c"))
+ "\
+Convert a running scheme program into an executable file.")
+
+;;;; Descriptions of these parameters is in "setjump.h".
+;;; (initial-heap-size ((define "INIT_HEAP_SIZE" (* 25000 sizeof-cell))))
+;;; (heap-segment-size ((define "HEAP_SEG_SIZE" (* 8100 sizeof-cell))))
+;;; (short-aligned-stack ((define "SHORT_ALIGN")))
+;;; (initial-malloc-limit ((define "INIT_MALLOC_LIMIT" 100000)))
+;;; (number-of-hash-buckets ((define "NUM_HASH_BUCKETS" 137)))
+;;; (minimum-gc-yield ((define "MIN_GC_YIELD" "(heap_size/4)")))
+
+ (heap-can-shrink ((define "DONT_GC_FREE_SEGMENTS"))
+ "\
+Define DONT_GC_FREE_SEGMENTS if you want segments of unused heap to
+not be freed up after garbage collection. This may reduce time in GC
+for *very* large working sets.")
+
+ (cheap-continuations ((define "CHEAP_CONTINUATIONS"))
+ "\
+If you only need straight stack continuations CHEAP_CONTINUATIONS will
+run faster and use less storage than not having it. Machines with
+unusual stacks need this. Also, if you incorporate new C code into
+scm which uses VMS system services or library routines (which need to
+unwind the stack in an ordrly manner) you may need to define
+CHEAP_CONTINUATIONS.")
+
+ (memoize-local-bindings ((define "MEMOIZE_LOCALS"))
+ "\
+Saves the interpeter from having to look up local bindings for every
+identifier reference")
+ ))
+ '(build-params
+ *parameter-columns*
+ *parameter-columns*
+ ((1 platform single platform
+ (lambda (pl) (list batch:platform))
+ #f
+ "what to build it for")
+ (2 target-name single string (lambda (pl) '("scm")) #f
+ "base name of target")
+ (3 c-lib nary symbol (lambda (pl) '(c)) #f
+ "C library (and include files)")
+ (4 define nary string #f #f "#define FLAG")
+ (5 implinit single string
+ (lambda (pl) (list (object->string
+ (in-vicinity (implementation-vicinity) "Init.scm"))))
+ #f "implementation vicinity")
+ (6 c-file nary filename #f #f "C source files")
+ (7 o-file nary filename #f #f "other object files")
+ (8 init nary string #f #f "initialization calls")
+ (9 compiled-init nary string #f #f "later initialization calls")
+ (10 features nary symbol
+ (lambda (pl) '(arrays inexact bignums))
+ (lambda (rdb) (((rdb 'open-table) 'features #f) 'get 'spec))
+ "features to include")
+ (11 what single build-whats
+ (lambda (pl) '(exe))
+ (lambda (rdb)
+ (define tab (((rdb 'open-table) 'build-whats #f) 'get 'class))
+ (define manifest ((((rdb 'open-table) 'manifest #f)
+ 'row:retrieve*)))
+ (lambda (what)
+ (define catgry (tab what))
+ `((c-file
+ ,@(map car
+ (remove-if-not
+ (lambda (row) (and (eq? 'c-source (cadr row))
+ (eq? catgry (caddr row))))
+ manifest)))
+ ,@(or ((((rdb 'open-table) 'build-whats #f) 'get 'spec) what)
+ '()))))
+ "what to build")
+ (12 batch-dialect single batch-dialect
+ guess-how
+ #f
+ "How to build")
+ (13 who single expression (lambda (pl) (list (current-output-port))) #f
+ "name of buildfile or port")
+ (14 compiler-options nary string #f #f "command-line compiler options")
+ (15 linker-options nary string #f #f "command-line linker options")
+
+ (17 batch-port nary expression #f #f
+ "port batch file will be written to.")
+ (18 c-defines nary expression #f #f "#defines for C")
+ (19 c-includes nary expression #f #f "library induced defines for C")
+ ))
+ '(build-pnames
+ ((name string))
+ ((parameter-index uint))
+ (
+ ("p" 1) ("platform" 1)
+ ("o" 2) ("outname" 2)
+ ("l" 3) ("libraries" 3)
+ ("D" 4) ("defines" 4)
+ ("s" 5) ("scheme initialization file" 5)
+ ("c" 6) ("c source files" 6)
+ ("j" 7) ("object files" 7)
+ ("i" 9) ("initialization calls" 9)
+ ("F" 10) ("features" 10)
+ ("t" 11) ("type" 11)
+ ("h" 12) ("batch dialect" 12)
+ ("w" 13) ("script name" 13)
+ ("compiler options" 14)
+ ("linker options" 15)
+ ))
+
+ '(*commands*
+ ((name symbol)) ;or just desc:*commands*
+ ((parameters parameter-list)
+ (parameter-names parameter-name-translation)
+ (procedure expression)
+ (documentation string))
+ ((build
+ build-params
+ build-pnames
+ build:build
+ "build program.")
+ (*initialize*
+ no-parameters
+ no-parameters
+ build:init
+ "SCM Build Database"))))
+
+;;;((build 'close-database))
+;;;(define build (open-database! "buildscm.scm" 'alist-table))
+
+(define build:error slib:error)
+(define build:c-libraries #f)
+(define build:lib-cc-flag #f)
+(define build:lib-ld-flag #f)
+(define build:c-supress #f)
+(define plan-command #f)
+
+;;; Look up command on a platform, but default to '*unknown* if not
+;;; initially found.
+
+(define (make-defaulting-platform-lookup getter)
+ (lambda (thing plat)
+ (define (look platform)
+ (let ((ans (getter thing platform)))
+ (cond (ans ans)
+ ((eq? '*unknown* platform)
+ (build:error "Couldn't find: " thing))
+ (else (look '*unknown*)))))
+ (look plat)))
+
+(define system:success? zero?)
+
+(require 'alist)
+(require 'common-list-functions)
+(require 'object->string)
+
+(define build:build
+ (lambda (rdb)
+ (lambda (parms)
+ (let ((expanders
+ (map (lambda (e) (and e (lambda (s) (e s))))
+ (map (lambda (f) (if f ((slib:eval f) rdb) f))
+ ((((rdb 'open-table) 'build-params #f)
+ 'get* 'expander))))))
+ (parameter-list-expand expanders parms)
+ (set! parms
+ (fill-empty-parameters
+ (map slib:eval
+ ((((rdb 'open-table) 'build-params #f)
+ 'get* 'default)))
+ parms))
+ (parameter-list-expand expanders parms))
+ (let* ((platform (car (parameter-list-ref parms 'platform)))
+ (init= (apply string-append
+ (map (lambda (c)
+ (string-append c "();"))
+ (parameter-list-ref parms 'init))))
+ (compiled-init=
+ (apply string-append
+ (map (lambda (c)
+ (string-append c "();"))
+ (parameter-list-ref parms 'compiled-init))))
+ (c-defines
+ `((define "IMPLINIT"
+ ,(car (parameter-list-ref parms 'implinit)))
+ ,@(if (string=? "" init=) '()
+ `((define "INITS" ,init=)))
+ ,@(if (string=? "" compiled-init=) '()
+ `((define "COMPILED_INITS" ,compiled-init=)))
+ ,@(map (lambda (d) (if (pair? d)
+ `(define ,@d)
+ `(define ,d #t)))
+ (parameter-list-ref parms 'define))))
+ (c-includes
+ (map (lambda (l) (build:lib-cc-flag l platform))
+ (parameter-list-ref parms 'c-lib)))
+ (batch-dialect (car (parameter-list-ref parms 'batch-dialect)))
+ (what (car (parameter-list-ref parms 'what)))
+ (c-proc (plan-command ((((rdb 'open-table) 'build-whats #f)
+ 'get 'c-proc)
+ what)
+ platform)))
+ (adjoin-parameters!
+ parms
+ (cons 'c-defines c-defines)
+ (cons 'c-includes c-includes)
+ )
+
+ (let ((name (car (parameter-list-ref parms 'who))))
+ (batch:call-with-output-script
+ parms
+ name
+ (lambda (batch-port)
+ (define o-files '())
+ (adjoin-parameters!
+ parms
+ (list 'batch-port batch-port))
+
+ ;; ================ Write file with C defines
+ (apply batch:lines->file parms
+ "scmflags.h"
+ (defines->c-defines c-defines))
+
+ ;; ================ Compile C source files
+ (set! o-files
+ (let ((supressors
+ (apply append
+ (map (lambda (l) (build:c-supress l platform))
+ (parameter-list-ref parms 'c-lib)))))
+ (c-proc (remove-if (lambda (file) (member file supressors))
+ (parameter-list-ref parms 'c-file))
+ parms)))
+
+ ;; ================ Link C object files
+ ((plan-command
+ ((((rdb 'open-table) 'build-whats #f) 'get 'o-proc) what)
+ platform)
+ (car (parameter-list-ref parms 'target-name))
+ (append o-files (parameter-list-ref parms 'o-file))
+ (append
+ (parameter-list-ref parms 'linker-options)
+ (map (lambda (l) (build:lib-ld-flag l platform))
+ (parameter-list-ref parms 'c-lib)))
+ parms))))))))
+
+(define (c-defines parms)
+ (parameter-list-ref parms 'c-defines))
+(define (c-includes parms)
+ (parameter-list-ref parms 'c-includes))
+(define (c-flags parms)
+ (parameter-list-ref parms 'compiler-options))
+
+(define (defines->c-defines defines)
+ (map
+ (lambda (d)
+ (case (caddr d)
+ ((#t) (string-join " " "#define" (cadr d)))
+ ((#f) (string-join " " "#undef" (cadr d)))
+ (else (apply string-join " " "#define" (cdr d)))))
+ defines))
+
+(define (defines->flags defines)
+ (map
+ (lambda (d)
+ (case (caddr d)
+ ((#t) (string-append "-D" (cadr d)))
+ ((#f) (string-append "-U" (cadr d)))
+ (else (string-append "-D" (cadr d) "=" (object->string (caddr d))))))
+ defines))
+
+(define (guess-how pl)
+ (let* ((plat (parameter-list-ref pl 'platform))
+ (platform (if (pair? plat) (car plat) batch:platform)))
+ (let ((os (or ((((build 'open-table) 'platform #f)
+ 'get 'operating-system) platform) batch:platform)))
+ (cond ((not os) (slib:error "OS corresponding to " platform " unknown"))
+ (else (list (os->batch-dialect os)))))))
+
+(define build:initializer
+ (lambda (rdb)
+ (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f))
+ (set! build:lib-cc-flag
+ (make-defaulting-platform-lookup
+ (build:c-libraries 'get 'compiler-flags)))
+ (set! build:lib-ld-flag
+ (make-defaulting-platform-lookup
+ (build:c-libraries 'get 'link-lib-flag)))
+ (set! build:c-supress
+ (make-defaulting-platform-lookup
+ (build:c-libraries 'get 'supress-files)))
+ (set! plan-command
+ (let ((lookup (make-defaulting-platform-lookup
+ (((rdb 'open-table) 'compile-commands #f)
+ 'get 'procedure))))
+ (lambda (thing plat)
+ (slib:eval (lookup thing plat)))))))
+(build:initializer build)
+
+(define (build-from-argv argv)
+ (cond ((string? argv)
+ (require 'read-command)
+ (set! argv (call-with-input-string argv read-command))))
+ (let ()
+ (define command (string->symbol (list-ref argv *optind*)))
+ (define argc (length argv))
+ (cond
+ ((pair? argv)
+ (set! *optind* (+ 1 *optind*))
+ ((make-command-server build '*commands*)
+ command
+ (lambda (comname comval options positions arities types
+ defaults checks aliases)
+ (let* ((params (getopt->parameter-list
+ argc argv options arities types aliases))
+ (fparams (fill-empty-parameters defaults params)))
+ (cond ((not (list? params)) #f)
+ ((not (check-parameters checks fparams)) #f)
+ ((not (check-arities (map arity->arity-spec arities) fparams))
+ (slib:error 'build-from-argv "arity error" fparams) #f)
+ (else (comval fparams))))))))))
+
+(define (build-from-whole-argv argv)
+ (set! *optind* 0)
+ (set! *optarg* #f)
+ (build-from-argv argv))
+
+(define b build-from-whole-argv)
+
+(define (b*)
+ (require 'read-command)
+ (do ((e (read-command) (read-command)))
+ ((eof-object? e))
+ (cond ((null? e))
+ (else
+ (cond ((not (string-ci=? (car e) "build"))
+ (set! e (cons "build" e))))
+ (write (build-from-whole-argv e))
+ (newline)))
+ (display "build> ")
+ (force-output)))
+
+(define (bi) (build-from-argv *argv*))
+
+(cond (*interactive*
+ (display "type (b \"build <command-line>\") to build") (newline)
+ (display "type (b*) to enter build command loop") (newline)))
diff --git a/configure b/configure
new file mode 100755
index 0000000..53d869e
--- /dev/null
+++ b/configure
@@ -0,0 +1,849 @@
+#!/bin/sh
+# Guess values for system-dependent variables and create Makefiles.
+# Generated automatically using autoconf.
+# Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+# Usage: configure [--srcdir=DIR] [--host=HOST] [--gas] [--nfp]
+# [--prefix=PREFIX] [--exec-prefix=PREFIX] [--with-PACKAGE[=VALUE]]
+# Ignores all args except --srcdir, --prefix, --exec-prefix, and
+# --with-PACKAGE[=VALUE] unless this script has special code to handle it.
+
+for arg
+do
+ # Handle --exec-prefix with a space before the argument.
+ if test x$next_exec_prefix = xyes; then exec_prefix=$arg; next_exec_prefix=
+ # Handle --host with a space before the argument.
+ elif test x$next_host = xyes; then next_host=
+ # Handle --prefix with a space before the argument.
+ elif test x$next_prefix = xyes; then prefix=$arg; next_prefix=
+ # Handle --srcdir with a space before the argument.
+ elif test x$next_srcdir = xyes; then srcdir=$arg; next_srcdir=
+ else
+ case $arg in
+ # For backward compatibility, recognize -exec-prefix and --exec_prefix.
+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* | --exe=* | --ex=* | --e=*)
+ exec_prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;;
+ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e)
+ next_exec_prefix=yes ;;
+
+ -gas | --gas | --ga | --g) ;;
+
+ -host=* | --host=* | --hos=* | --ho=* | --h=*) ;;
+ -host | --host | --hos | --ho | --h)
+ next_host=yes ;;
+
+ -nfp | --nfp | --nf) ;;
+
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;;
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ next_prefix=yes ;;
+
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*)
+ srcdir=`echo $arg | sed 's/[-a-z_]*=//'` ;;
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s)
+ next_srcdir=yes ;;
+
+ -with-* | --with-*)
+ package=`echo $arg|sed -e 's/-*with-//' -e 's/=.*//'`
+ # Reject names that aren't valid shell variable names.
+ if test -n "`echo $package| sed 's/[-a-zA-Z0-9_]//g'`"; then
+ echo "configure: $package: invalid package name" >&2; exit 1
+ fi
+ package=`echo $package| sed 's/-/_/g'`
+ case "$arg" in
+ *=*) val="`echo $arg|sed 's/[^=]*=//'`" ;;
+ *) val=1 ;;
+ esac
+ eval "with_$package='$val'" ;;
+
+ -v | -verbose | --verbose | --verbos | --verbo | --verb | --ver | --ve | --v)
+ verbose=yes ;;
+
+ *) ;;
+ esac
+ fi
+done
+
+trap 'rm -fr conftest* confdefs* core; exit 1' 1 3 15
+trap 'rm -f confdefs*' 0
+
+# NLS nuisances.
+# These must not be set unconditionally because not all systems understand
+# e.g. LANG=C (notably SCO).
+if test "${LC_ALL+set}" = 'set' ; then LC_ALL=C; export LC_ALL; fi
+if test "${LANG+set}" = 'set' ; then LANG=C; export LANG; fi
+
+rm -f conftest* confdefs.h
+# AIX cpp loses on an empty file, so make sure it contains at least a newline.
+echo > confdefs.h
+compile='${CC-cc} $CFLAGS conftest.c -o conftest $LIBS >/dev/null 2>&1'
+
+# A filename unique to this package, relative to the directory that
+# configure is in, which we can look for to find out if srcdir is correct.
+unique_file=scl.c
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+ srcdirdefaulted=yes
+ # Try the directory containing this script, then `..'.
+ prog=$0
+ confdir=`echo $prog|sed 's%/[^/][^/]*$%%'`
+ test "X$confdir" = "X$prog" && confdir=.
+ srcdir=$confdir
+ if test ! -r $srcdir/$unique_file; then
+ srcdir=..
+ fi
+fi
+if test ! -r $srcdir/$unique_file; then
+ if test x$srcdirdefaulted = xyes; then
+ echo "configure: Can not find sources in \`${confdir}' or \`..'." 1>&2
+ else
+ echo "configure: Can not find sources in \`${srcdir}'." 1>&2
+ fi
+ exit 1
+fi
+# Preserve a srcdir of `.' to avoid automounter screwups with pwd.
+# But we can't avoid them for `..', to make subdirectories work.
+case $srcdir in
+ .|/*|~*) ;;
+ *) srcdir=`cd $srcdir; pwd` ;; # Make relative path absolute.
+esac
+
+
+# Save the original args to write them into config.status later.
+configure_args="$*"
+
+
+
+test -z "$CFLAGS" && CFLAGS=-g
+test -z "$LDFLAGS" && LDFLAGS=-g
+
+if test -z "$CC"; then
+ # Extract the first word of `gcc', so it can be a program name with args.
+ set dummy gcc; word=$2
+ echo checking for $word
+ IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:"
+ for dir in $PATH; do
+ test -z "$dir" && dir=.
+ if test -f $dir/$word; then
+ CC="gcc"
+ break
+ fi
+ done
+ IFS="$saveifs"
+fi
+test -z "$CC" && CC="cc"
+test -n "$CC" && test -n "$verbose" && echo " setting CC to $CC"
+
+# Find out if we are using GNU C, under whatever name.
+cat > conftest.c <<EOF
+#ifdef __GNUC__
+ yes
+#endif
+EOF
+${CC-cc} -E conftest.c > conftest.out 2>&1
+if egrep yes conftest.out >/dev/null 2>&1; then
+ GCC=1 # For later tests.
+fi
+rm -f conftest*
+
+# Make sure to not get the incompatible SysV /etc/install and
+# /usr/sbin/install, which might be in PATH before a BSD-like install,
+# or the SunOS /usr/etc/install directory, or the AIX /bin/install,
+# or the AFS install, which mishandles nonexistent args, or
+# /usr/ucb/install on SVR4, which tries to use the nonexistent group
+# `staff'. On most BSDish systems install is in /usr/bin, not /usr/ucb
+# anyway. Sigh.
+if test "z${INSTALL}" = "z" ; then
+ echo checking for install
+ IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:"
+ for dir in $PATH; do
+ test -z "$dir" && dir=.
+ case $dir in
+ /etc|/usr/sbin|/usr/etc|/usr/afsws/bin|/usr/ucb) ;;
+ *)
+ if test -f $dir/installbsd; then
+ INSTALL="$dir/installbsd -c" # OSF1
+ INSTALL_PROGRAM='$(INSTALL)'
+ INSTALL_DATA='$(INSTALL) -m 644'
+ break
+ fi
+ if test -f $dir/install; then
+ if grep dspmsg $dir/install >/dev/null 2>&1; then
+ : # AIX
+ else
+ INSTALL="$dir/install -c"
+ INSTALL_PROGRAM='$(INSTALL)'
+ INSTALL_DATA='$(INSTALL) -m 644'
+ break
+ fi
+ fi
+ ;;
+ esac
+ done
+ IFS="$saveifs"
+fi
+INSTALL=${INSTALL-cp}
+test -n "$verbose" && echo " setting INSTALL to $INSTALL"
+INSTALL_PROGRAM=${INSTALL_PROGRAM-'$(INSTALL)'}
+test -n "$verbose" && echo " setting INSTALL_PROGRAM to $INSTALL_PROGRAM"
+INSTALL_DATA=${INSTALL_DATA-'$(INSTALL)'}
+test -n "$verbose" && echo " setting INSTALL_DATA to $INSTALL_DATA"
+
+echo checking how to run the C preprocessor
+if test -z "$CPP"; then
+ # This must be in double quotes, not single quotes, because CPP may get
+ # substituted into the Makefile and ``${CC-cc}'' will simply confuse
+ # make. It must be expanded now.
+ CPP="${CC-cc} -E"
+ cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <stdio.h>
+Syntax Error
+EOF
+err=`eval "($CPP conftest.c >/dev/null) 2>&1"`
+if test -z "$err"; then
+ :
+else
+ rm -rf conftest*
+ CPP=/lib/cpp
+fi
+rm -f conftest*
+fi
+test ".${verbose}" != "." && echo " setting CPP to $CPP"
+
+if test -z "$RANLIB"; then
+ # Extract the first word of `ranlib', so it can be a program name with args.
+ set dummy ranlib; word=$2
+ echo checking for $word
+ IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:"
+ for dir in $PATH; do
+ test -z "$dir" && dir=.
+ if test -f $dir/$word; then
+ RANLIB="ranlib"
+ break
+ fi
+ done
+ IFS="$saveifs"
+fi
+test -z "$RANLIB" && RANLIB=":"
+test -n "$RANLIB" && test -n "$verbose" && echo " setting RANLIB to $RANLIB"
+
+echo checking for AIX
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#ifdef _AIX
+ yes
+#endif
+
+EOF
+eval "$CPP conftest.c > conftest.out 2>&1"
+if egrep "yes" conftest.out >/dev/null 2>&1; then
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining _ALL_SOURCE"
+echo "#define" _ALL_SOURCE 1 >> confdefs.h
+DEFS="$DEFS -D_ALL_SOURCE=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}_ALL_SOURCE\${SEDdB}_ALL_SOURCE\${SEDdC}1\${SEDdD}
+\${SEDuA}_ALL_SOURCE\${SEDuB}_ALL_SOURCE\${SEDuC}1\${SEDuD}
+\${SEDeA}_ALL_SOURCE\${SEDeB}_ALL_SOURCE\${SEDeC}1\${SEDeD}
+"
+}
+
+
+fi
+rm -f conftest*
+
+
+echo checking for POSIXized ISC
+if test -d /etc/conf/kconfig.d &&
+ grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
+then
+ ISC=1 # If later tests want to check for ISC.
+
+{
+test -n "$verbose" && \
+echo " defining _POSIX_SOURCE"
+echo "#define" _POSIX_SOURCE 1 >> confdefs.h
+DEFS="$DEFS -D_POSIX_SOURCE=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD}
+\${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD}
+\${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD}
+"
+}
+
+ if test -n "$GCC"; then
+ CC="$CC -posix"
+ else
+ CC="$CC -Xp"
+ fi
+fi
+
+echo checking for minix/config.h
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <minix/config.h>
+EOF
+err=`eval "($CPP conftest.c >/dev/null) 2>&1"`
+if test -z "$err"; then
+ rm -rf conftest*
+ MINIX=1
+
+fi
+rm -f conftest*
+
+# The Minix shell can't assign to the same variable on the same line!
+if test -n "$MINIX"; then
+
+{
+test -n "$verbose" && \
+echo " defining _POSIX_SOURCE"
+echo "#define" _POSIX_SOURCE 1 >> confdefs.h
+DEFS="$DEFS -D_POSIX_SOURCE=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD}
+\${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD}
+\${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD}
+"
+}
+
+
+{
+test -n "$verbose" && \
+echo " defining" _POSIX_1_SOURCE to be 2
+echo "#define" _POSIX_1_SOURCE 2 >> confdefs.h
+DEFS="$DEFS -D_POSIX_1_SOURCE=2"
+SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_1_SOURCE\${SEDdB}_POSIX_1_SOURCE\${SEDdC}2\${SEDdD}
+\${SEDuA}_POSIX_1_SOURCE\${SEDuB}_POSIX_1_SOURCE\${SEDuC}2\${SEDuD}
+\${SEDeA}_POSIX_1_SOURCE\${SEDeB}_POSIX_1_SOURCE\${SEDeC}2\${SEDeD}
+"
+}
+
+
+{
+test -n "$verbose" && \
+echo " defining _MINIX"
+echo "#define" _MINIX 1 >> confdefs.h
+DEFS="$DEFS -D_MINIX=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}_MINIX\${SEDdB}_MINIX\${SEDdC}1\${SEDdD}
+\${SEDuA}_MINIX\${SEDuB}_MINIX\${SEDuC}1\${SEDuD}
+\${SEDeA}_MINIX\${SEDeB}_MINIX\${SEDeC}1\${SEDeD}
+"
+}
+
+fi
+
+echo checking for ANSI C header files
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+EOF
+err=`eval "($CPP conftest.c >/dev/null) 2>&1"`
+if test -z "$err"; then
+ rm -rf conftest*
+ # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
+echo '#include "confdefs.h"
+#include <string.h>' > conftest.c
+eval "$CPP conftest.c > conftest.out 2>&1"
+if egrep "memchr" conftest.out >/dev/null 2>&1; then
+ rm -rf conftest*
+ # SGI's /bin/cc from Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <ctype.h>
+#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
+#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
+#define XOR(e,f) (((e) && !(f)) || (!(e) && (f)))
+int main () { int i; for (i = 0; i < 256; i++)
+if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
+exit (0); }
+
+EOF
+eval $compile
+if test -s conftest && (./conftest; exit) 2>/dev/null; then
+
+{
+test -n "$verbose" && \
+echo " defining STDC_HEADERS"
+echo "#define" STDC_HEADERS 1 >> confdefs.h
+DEFS="$DEFS -DSTDC_HEADERS=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}STDC_HEADERS\${SEDdB}STDC_HEADERS\${SEDdC}1\${SEDdD}
+\${SEDuA}STDC_HEADERS\${SEDuB}STDC_HEADERS\${SEDuC}1\${SEDuD}
+\${SEDeA}STDC_HEADERS\${SEDeB}STDC_HEADERS\${SEDeC}1\${SEDeD}
+"
+}
+
+
+fi
+rm -fr conftest*
+
+fi
+rm -f conftest*
+
+
+fi
+rm -f conftest*
+
+for hdr in unistd.h string.h memory.h limits.h time.h sys/types.h sys/time.h sys/timeb.h sys/times.h
+do
+trhdr=HAVE_`echo $hdr | tr '[a-z]./' '[A-Z]__'`
+echo checking for ${hdr}
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <${hdr}>
+EOF
+err=`eval "($CPP conftest.c >/dev/null) 2>&1"`
+if test -z "$err"; then
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining ${trhdr}"
+echo "#define" ${trhdr} 1 >> confdefs.h
+DEFS="$DEFS -D${trhdr}=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}${trhdr}\${SEDdB}${trhdr}\${SEDdC}1\${SEDdD}
+\${SEDuA}${trhdr}\${SEDuB}${trhdr}\${SEDuC}1\${SEDuD}
+\${SEDeA}${trhdr}\${SEDeB}${trhdr}\${SEDeC}1\${SEDeD}
+"
+}
+
+
+fi
+rm -f conftest*
+done
+
+echo checking for whether time.h and sys/time.h may both be included
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <sys/types.h>
+#include <sys/time.h>
+#include <time.h>
+int main() { exit(0); }
+int t() { struct tm *tp; }
+EOF
+if eval $compile; then
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining TIME_WITH_SYS_TIME"
+echo "#define" TIME_WITH_SYS_TIME 1 >> confdefs.h
+DEFS="$DEFS -DTIME_WITH_SYS_TIME=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}TIME_WITH_SYS_TIME\${SEDdB}TIME_WITH_SYS_TIME\${SEDdC}1\${SEDdD}
+\${SEDuA}TIME_WITH_SYS_TIME\${SEDuB}TIME_WITH_SYS_TIME\${SEDuC}1\${SEDuD}
+\${SEDeA}TIME_WITH_SYS_TIME\${SEDeB}TIME_WITH_SYS_TIME\${SEDeC}1\${SEDeD}
+"
+}
+
+
+fi
+rm -f conftest*
+
+for func in ftime times
+do
+trfunc=HAVE_`echo $func | tr '[a-z]' '[A-Z]'`
+echo checking for ${func}
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <ctype.h>
+int main() { exit(0); }
+int t() {
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_${func}) || defined (__stub___${func})
+choke me
+#else
+/* Override any gcc2 internal prototype to avoid an error. */
+extern char ${func}(); ${func}();
+#endif
+ }
+EOF
+if eval $compile; then
+ rm -rf conftest*
+ {
+test -n "$verbose" && \
+echo " defining ${trfunc}"
+echo "#define" ${trfunc} 1 >> confdefs.h
+DEFS="$DEFS -D${trfunc}=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}${trfunc}\${SEDdB}${trfunc}\${SEDdC}1\${SEDdD}
+\${SEDuA}${trfunc}\${SEDuB}${trfunc}\${SEDuC}1\${SEDuD}
+\${SEDeA}${trfunc}\${SEDeB}${trfunc}\${SEDeC}1\${SEDeD}
+"
+}
+
+
+fi
+rm -f conftest*
+done
+
+echo checking for return type of signal handlers
+cat > conftest.c <<EOF
+#include "confdefs.h"
+#include <sys/types.h>
+#include <signal.h>
+#ifdef signal
+#undef signal
+#endif
+extern void (*signal ()) ();
+int main() { exit(0); }
+int t() { int i; }
+EOF
+if eval $compile; then
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining" RETSIGTYPE to be void
+echo "#define" RETSIGTYPE void >> confdefs.h
+DEFS="$DEFS -DRETSIGTYPE=void"
+SEDDEFS="${SEDDEFS}\${SEDdA}RETSIGTYPE\${SEDdB}RETSIGTYPE\${SEDdC}void\${SEDdD}
+\${SEDuA}RETSIGTYPE\${SEDuB}RETSIGTYPE\${SEDuC}void\${SEDuD}
+\${SEDeA}RETSIGTYPE\${SEDeB}RETSIGTYPE\${SEDeC}void\${SEDeD}
+"
+}
+
+
+else
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining" RETSIGTYPE to be int
+echo "#define" RETSIGTYPE int >> confdefs.h
+DEFS="$DEFS -DRETSIGTYPE=int"
+SEDDEFS="${SEDDEFS}\${SEDdA}RETSIGTYPE\${SEDdB}RETSIGTYPE\${SEDdC}int\${SEDdD}
+\${SEDuA}RETSIGTYPE\${SEDuB}RETSIGTYPE\${SEDuC}int\${SEDuD}
+\${SEDeA}RETSIGTYPE\${SEDeB}RETSIGTYPE\${SEDeC}int\${SEDeD}
+"
+}
+
+fi
+rm -f conftest*
+
+
+prog='/* Ultrix mips cc rejects this. */
+typedef int charset[2]; const charset x;
+/* SunOS 4.1.1 cc rejects this. */
+char const *const *ccp;
+char **p;
+/* AIX XL C 1.02.0.0 rejects this.
+ It does not let you subtract one const X* pointer from another in an arm
+ of an if-expression whose if-part is not a constant expression */
+const char *g = "string";
+ccp = &g + (g ? g-g : 0);
+/* HPUX 7.0 cc rejects these. */
+++ccp;
+p = (char**) ccp;
+ccp = (char const *const *) p;
+{ /* SCO 3.2v4 cc rejects this. */
+ char *t;
+ char const *s = 0 ? (char *) 0 : (char const *) 0;
+
+ *t++ = 0;
+}
+{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */
+ int x[] = {25,17};
+ const int *foo = &x[0];
+ ++foo;
+}
+{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */
+ typedef const int *iptr;
+ iptr p = 0;
+ ++p;
+}
+{ /* AIX XL C 1.02.0.0 rejects this saying
+ "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */
+ struct s { int j; const int *ap[3]; };
+ struct s *b; b->j = 5;
+}
+{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */
+ const int foo = 10;
+}'
+echo checking for lack of working const
+cat > conftest.c <<EOF
+#include "confdefs.h"
+
+int main() { exit(0); }
+int t() { $prog }
+EOF
+if eval $compile; then
+ :
+else
+ rm -rf conftest*
+
+{
+test -n "$verbose" && \
+echo " defining" const to be empty
+echo "#define" const >> confdefs.h
+DEFS="$DEFS -Dconst="
+SEDDEFS="${SEDDEFS}\${SEDdA}const\${SEDdB}const\${SEDdC}\${SEDdD}
+\${SEDuA}const\${SEDuB}const\${SEDuC}\${SEDuD}
+\${SEDeA}const\${SEDeB}const\${SEDeC}\${SEDeD}
+"
+}
+
+fi
+rm -f conftest*
+
+echo checking whether $CC and cc understand -c and -o together
+echo 'foo(){}' > conftest.c
+# Make sure it works both with $CC and with simple cc.
+# We do the test twice because some compilers refuse to overwrite an
+# existing .o file with -o, though they will create one.
+if ${CC-cc} -c conftest.c -o conftest.o >/dev/null 2>&1 \
+ && test -f conftest.o && ${CC-cc} -c conftest.c -o conftest.o >/dev/null 2>&1
+then
+ # Test first that cc exists at all.
+ if cc -c conftest.c >/dev/null 2>&1
+ then
+ if cc -c conftest.c -o conftest2.o >/dev/null 2>&1 && \
+ test -f conftest2.o && cc -c conftest.c -o conftest2.o >/dev/null 2>&1
+ then
+ :
+ else
+
+{
+test -n "$verbose" && \
+echo " defining NO_MINUS_C_MINUS_O"
+echo "#define" NO_MINUS_C_MINUS_O 1 >> confdefs.h
+DEFS="$DEFS -DNO_MINUS_C_MINUS_O=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}NO_MINUS_C_MINUS_O\${SEDdB}NO_MINUS_C_MINUS_O\${SEDdC}1\${SEDdD}
+\${SEDuA}NO_MINUS_C_MINUS_O\${SEDuB}NO_MINUS_C_MINUS_O\${SEDuC}1\${SEDuD}
+\${SEDeA}NO_MINUS_C_MINUS_O\${SEDeB}NO_MINUS_C_MINUS_O\${SEDeC}1\${SEDeD}
+"
+}
+
+ fi
+ fi
+else
+
+{
+test -n "$verbose" && \
+echo " defining NO_MINUS_C_MINUS_O"
+echo "#define" NO_MINUS_C_MINUS_O 1 >> confdefs.h
+DEFS="$DEFS -DNO_MINUS_C_MINUS_O=1"
+SEDDEFS="${SEDDEFS}\${SEDdA}NO_MINUS_C_MINUS_O\${SEDdB}NO_MINUS_C_MINUS_O\${SEDdC}1\${SEDdD}
+\${SEDuA}NO_MINUS_C_MINUS_O\${SEDuB}NO_MINUS_C_MINUS_O\${SEDuC}1\${SEDuD}
+\${SEDeA}NO_MINUS_C_MINUS_O\${SEDeB}NO_MINUS_C_MINUS_O\${SEDeC}1\${SEDeD}
+"
+}
+
+fi
+rm -f conftest*
+
+
+
+
+# Set default prefixes.
+if test -n "$prefix"; then
+ test -z "$exec_prefix" && exec_prefix='${prefix}'
+ prsub="s%^prefix\\([ ]*\\)=\\([ ]*\\).*$%prefix\\1=\\2$prefix%"
+fi
+if test -n "$exec_prefix"; then
+ prsub="$prsub
+s%^exec_prefix\\([ ]*\\)=\\([ ]*\\).*$%exec_prefix\\1=\\2$exec_prefix%"
+fi
+# Quote sed substitution magic chars in DEFS.
+cat >conftest.def <<EOF
+$DEFS
+EOF
+escape_ampersand_and_backslash='s%[&\\]%\\&%g'
+DEFS=`sed "$escape_ampersand_and_backslash" <conftest.def`
+rm -f conftest.def
+# Substitute for predefined variables.
+
+trap 'rm -f config.status; exit 1' 1 3 15
+echo creating config.status
+rm -f config.status
+cat > config.status <<EOF
+#!/bin/sh
+# Generated automatically by configure.
+# Run this file to recreate the current configuration.
+# This directory was configured as follows,
+# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+#
+# $0 $configure_args
+
+for arg
+do
+ case "\$arg" in
+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+ echo running \${CONFIG_SHELL-/bin/sh} $0 $configure_args
+ exec \${CONFIG_SHELL-/bin/sh} $0 $configure_args ;;
+ *) echo "Usage: config.status --recheck" 2>&1; exit 1 ;;
+ esac
+done
+
+trap 'rm -fr Makefile scmconfig.h conftest*; exit 1' 1 3 15
+CFLAGS='$CFLAGS'
+LDFLAGS='$LDFLAGS'
+CC='$CC'
+INSTALL='$INSTALL'
+INSTALL_PROGRAM='$INSTALL_PROGRAM'
+INSTALL_DATA='$INSTALL_DATA'
+CPP='$CPP'
+RANLIB='$RANLIB'
+LIBOBJS='$LIBOBJS'
+LIBS='$LIBS'
+srcdir='$srcdir'
+prefix='$prefix'
+exec_prefix='$exec_prefix'
+prsub='$prsub'
+extrasub='$extrasub'
+EOF
+cat >> config.status <<\EOF
+
+top_srcdir=$srcdir
+
+CONFIG_FILES=${CONFIG_FILES-"Makefile"}
+for file in .. ${CONFIG_FILES}; do if test "x$file" != x..; then
+ srcdir=$top_srcdir
+ # Remove last slash and all that follows it. Not all systems have dirname.
+ dir=`echo $file|sed 's%/[^/][^/]*$%%'`
+ if test "$dir" != "$file"; then
+ test "$top_srcdir" != . && srcdir=$top_srcdir/$dir
+ test ! -d $dir && mkdir $dir
+ fi
+ echo creating $file
+ rm -f $file
+ echo "# Generated automatically from `echo $file|sed 's|.*/||'`.in by configure." > $file
+ sed -e "
+$prsub
+$extrasub
+s%@CFLAGS@%$CFLAGS%g
+s%@LDFLAGS@%$LDFLAGS%g
+s%@CC@%$CC%g
+s%@INSTALL@%$INSTALL%g
+s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
+s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@CPP@%$CPP%g
+s%@RANLIB@%$RANLIB%g
+s%@LIBOBJS@%$LIBOBJS%g
+s%@LIBS@%$LIBS%g
+s%@srcdir@%$srcdir%g
+s%@DEFS@%-DHAVE_CONFIG_H%" $top_srcdir/${file}.in >> $file
+fi; done
+
+CONFIG_HEADERS=${CONFIG_HEADERS-"scmconfig.h"}
+for file in .. ${CONFIG_HEADERS}; do if test "x$file" != x..; then
+echo creating $file
+
+# These sed commands are put into SEDDEFS when defining a macro.
+# They are broken into pieces to make the sed script easier to manage.
+# They are passed to sed as "A NAME B NAME C VALUE D", where NAME
+# is the cpp macro being defined and VALUE is the value it is being given.
+# Each defining turns into a single global substitution command.
+#
+# SEDd sets the value in "#define NAME VALUE" lines.
+SEDdA='s@^\([ ]*\)#\([ ]*define[ ][ ]*\)'
+SEDdB='\([ ][ ]*\)[^ ]*@\1#\2'
+SEDdC='\3'
+SEDdD='@g'
+# SEDu turns "#undef NAME" with trailing blanks into "#define NAME VALUE".
+SEDuA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)'
+SEDuB='\([ ]\)@\1#\2define\3'
+SEDuC=' '
+SEDuD='\4@g'
+# SEDe turns "#undef NAME" without trailing blanks into "#define NAME VALUE".
+SEDeA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)'
+SEDeB='$@\1#\2define\3'
+SEDeC=' '
+SEDeD='@g'
+rm -f conftest.sed
+EOF
+# Turn off quoting long enough to insert the sed commands.
+rm -f conftest.sh
+cat > conftest.sh <<EOF
+$SEDDEFS
+EOF
+
+# Break up $SEDDEFS (now in conftest.sh) because some shells have a limit
+# on the size of here documents.
+
+# Maximum number of lines to put in a single here document.
+maxshlines=9
+
+while :
+do
+ # wc gives bogus results for an empty file on some systems.
+ lines=`grep -c . conftest.sh`
+ if test -z "$lines" || test "$lines" -eq 0; then break; fi
+ rm -f conftest.s1 conftest.s2
+ sed ${maxshlines}q conftest.sh > conftest.s1 # Like head -20.
+ sed 1,${maxshlines}d conftest.sh > conftest.s2 # Like tail +21.
+ # Write a limited-size here document to append to conftest.sed.
+ echo 'cat >> conftest.sed <<CONFEOF' >> config.status
+ cat conftest.s1 >> config.status
+ echo 'CONFEOF' >> config.status
+ rm -f conftest.s1 conftest.sh
+ mv conftest.s2 conftest.sh
+done
+rm -f conftest.sh
+
+# Now back to your regularly scheduled config.status.
+cat >> config.status <<\EOF
+# This sed command replaces #undef's with comments. This is necessary, for
+# example, in the case of _POSIX_SOURCE, which is predefined and required
+# on some systems where configure will not decide to define it in
+# scmconfig.h.
+cat >> conftest.sed <<\CONFEOF
+s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */,
+CONFEOF
+rm -f conftest.h
+# Break up the sed commands because old seds have small limits.
+maxsedlines=20
+cp $top_srcdir/$file.in conftest.h1
+while :
+do
+ lines=`grep -c . conftest.sed`
+ if test -z "$lines" || test "$lines" -eq 0; then break; fi
+ rm -f conftest.s1 conftest.s2 conftest.h2
+ sed ${maxsedlines}q conftest.sed > conftest.s1 # Like head -20.
+ sed 1,${maxsedlines}d conftest.sed > conftest.s2 # Like tail +21.
+ sed -f conftest.s1 < conftest.h1 > conftest.h2
+ rm -f conftest.s1 conftest.h1 conftest.sed
+ mv conftest.h2 conftest.h1
+ mv conftest.s2 conftest.sed
+done
+rm -f conftest.sed conftest.h
+echo "/* $file. Generated automatically by configure. */" > conftest.h
+cat conftest.h1 >> conftest.h
+rm -f conftest.h1
+if cmp -s $file conftest.h 2>/dev/null; then
+ # The file exists and we would not be changing it.
+ echo "$file is unchanged"
+ rm -f conftest.h
+else
+ rm -f $file
+ mv conftest.h $file
+fi
+fi; done
+
+
+
+exit 0
+EOF
+chmod +x config.status
+${CONFIG_SHELL-/bin/sh} config.status
+
+
diff --git a/configure.in b/configure.in
new file mode 100644
index 0000000..76c60ad
--- /dev/null
+++ b/configure.in
@@ -0,0 +1,33 @@
+dnl Process this file with autoconf to produce a configure script.
+AC_INIT(scl.c)
+AC_CONFIG_HEADER(scmconfig.h)
+
+test -z "$CFLAGS" && CFLAGS=-g AC_SUBST(CFLAGS)
+test -z "$LDFLAGS" && LDFLAGS=-g AC_SUBST(LDFLAGS)
+
+AC_PROG_CC
+AC_PROG_INSTALL
+AC_PROG_CPP
+AC_PROG_RANLIB
+AC_AIX
+AC_ISC_POSIX
+AC_MINIX
+AC_STDC_HEADERS
+AC_HAVE_HEADERS(unistd.h string.h memory.h limits.h time.h sys/types.h sys/time.h sys/timeb.h sys/times.h)
+AC_TIME_WITH_SYS_TIME
+AC_HAVE_FUNCS(ftime times getcwd)
+AC_RETSIGTYPE
+AC_CONST
+AC_MINUS_C_MINUS_O
+dnl AC_PREFIX(scm)
+
+AC_SUBST(LIBOBJS)
+
+AC_OUTPUT(Makefile)
+
+dnl Local Variables:
+dnl comment-start: "dnl "
+dnl comment-end: ""
+dnl comment-start-skip: "\\bdnl\\b\\s *"
+dnl compile-command: "make configure scmconfig.h.in"
+dnl End:
diff --git a/continue.c b/continue.c
new file mode 100644
index 0000000..b28fe6e
--- /dev/null
+++ b/continue.c
@@ -0,0 +1,255 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "continue.c" Scheme Continuations for C.
+ Author: Aubrey Jaffer */
+
+/* "setjump.h" contains definitions for the `other' field (type
+ CONTINUATION_OTHER) the struct Continuation. "setjump.h" must
+ #include "continue.h". CONTINUATION_OTHER defaults to `long' */
+
+#define IN_CONTINUE_C
+#ifdef USE_CONTINUE_H
+# include "continue.h"
+#else
+# include "setjump.h"
+#endif
+
+/* For platforms with short integers, we use thrown_value instead of
+ the value returned from setjmp so that any (long) value can be
+ returned. */
+
+#ifdef SHORT_INT
+long thrown_value;
+#endif
+
+/* stack_size() returns the number of units of size STACKITEM which
+ fit between @var{start} and the current top of stack. No check is
+ done in this routine to ensure that @var{start} is actually in the
+ current stack segment. */
+
+long stack_size(start)
+ STACKITEM *start;
+{
+ STACKITEM stack;
+#ifdef STACK_GROWS_UP
+ return &stack - start;
+#else
+ return start - &stack;
+#endif /* def STACK_GROWS_UP */
+}
+
+/* make_root_continuation() allocates (malloc) storage for a
+ CONTINUATION near the current extent of stack. This newly
+ allocated CONTINUATION is returned if successful, 0 if not. After
+ make_root_continuation() returns, the calling routine still needs
+ to `setjmp(new_continuation->jmpbuf)' in order to complete the
+ capture of this continuation. */
+
+CONTINUATION *make_root_continuation(stack_base)
+ STACKITEM *stack_base;
+{
+ CONTINUATION *cont;
+ cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
+ if (!cont) return 0;
+ cont->length = 0;
+ cont->stkbse = stack_base;
+ cont->parent = cont;
+ return cont;
+}
+
+/* make_continuation() allocates storage for the current continuation,
+ copying (or encapsulating) the stack state from parent_cont->stkbse
+ to the current top of stack. The newly allocated CONTINUATION is
+ returned if successful, 0 if not. After make_continuation()
+ returns, the calling routine still needs to
+ `setjmp(new_continuation->jmpbuf)' in order to complete the capture
+ of this continuation. */
+
+/* Note: allocating local (stack) storage for the CONTINUATION would
+ not work; Think about it. */
+
+CONTINUATION *make_continuation(parent_cont)
+ CONTINUATION *parent_cont;
+{
+ CONTINUATION *cont;
+#ifdef CHEAP_CONTINUATIONS
+ cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
+ if (!cont) return 0;
+ cont->length = 0;
+ cont->stkbse = parent_cont->stkbse;
+#else
+ long j;
+ register STACKITEM *src, *dst;
+ FLUSH_REGISTER_WINDOWS;
+ j = stack_size(parent_cont->stkbse);
+ cont = (CONTINUATION *)malloc((sizeof(CONTINUATION) + j*sizeof(STACKITEM)));
+ if (!cont) return 0;
+ cont->length = j;
+ cont->stkbse = parent_cont->stkbse;
+ src = cont->stkbse;
+# ifdef STACK_GROWS_UP
+ src += parent_cont->length;
+# else
+ src -= parent_cont->length + cont->length;
+# endif/* ndef STACK_GROWS_UP */
+ dst = (STACKITEM *)(cont + 1);
+ for (j = cont->length; 0 <= --j; ) *dst++ = *src++;
+#endif /* ndef CHEAP_CONTINUATIONS */
+ cont->parent = parent_cont;
+ return cont;
+}
+
+/* free_continuation() is trivial, but who knows what the future
+ holds. */
+
+void free_continuation(cont)
+ CONTINUATION *cont;
+{
+ free(cont);
+}
+
+/* Final routine involved in throw()ing to a continuation. After
+ ensuring that there is sufficient room on the stack for the saved
+ continuation, dynthrow() copies the continuation onto the stack and
+ longjmp()s into it. The routine does not return. */
+
+/* If you use conservative GC and your Sparc(SUN-4) heap is growing
+ out of control:
+
+ You are experiencing a GC problem peculiar to the Sparc. The
+ problem is that contin doesn't know how to clear register windows.
+ Every location which is not reused still gets marked at GC time.
+ This causes lots of stuff which should be collected to not be.
+ This will be a problem with any *conservative* GC until we find
+ what instruction will clear the register windows. This problem is
+ exacerbated by using lots of make-CONTINUATION.
+
+ Possibly adding the following before the thrown_value = val; line
+ might help to clear out unused stack above the continuation (a
+ small part of the problem).
+
+#ifdef sparc
+ bzero((void *)&a, sizeof(STACKITEM) *
+ (((STACKITEM *)&a) - (dst - cont->length)))
+#endif
+
+ Let me know if you try it. */
+
+void dynthrow(a)
+ long *a;
+{
+ register CONTINUATION *cont = (CONTINUATION *)(a[0]);
+ long val = a[1];
+#ifndef CHEAP_CONTINUATIONS
+ register long j;
+ register STACKITEM *src, *dst = cont->stkbse;
+# ifdef STACK_GROWS_UP
+ if (a[2] && (a - ((long *)a[3]) < 100))
+ puts("grow_throw: check if long growth[100]; being optimized out");
+ /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
+ if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a);
+# else
+ if (a[2] && (((long *)a[3]) - a < 100))
+ puts("grow_throw: check if long growth[100]; being optimized out");
+ /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
+ dst -= cont->length;
+ if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a);
+# endif/* def STACK_GROWS_UP */
+ FLUSH_REGISTER_WINDOWS;
+ src = (STACKITEM *)(cont + 1);
+ for (j = cont->length;0 <= --j;) *dst++ = *src++;
+#endif /* ndef CHEAP_CONTINUATIONS */
+#ifdef SHORT_INT
+ thrown_value = val;
+ longjmp(cont->jmpbuf, 1);
+#else
+ longjmp(cont->jmpbuf, val);
+#endif
+}
+
+/* grow_throw() grows the stack by 100 long words. If the "sizeof
+ growth" assignment is not sufficient to restrain your overly
+ optimistic compiler, the stack will grow by much less and
+ grow_throw() and dynthrow() will waste time calling each other. To
+ fix this you will have to compile grow_throw() in a separate file
+ so the compiler won't be able to guess that the growth array isn't
+ all used. */
+
+#ifndef CHEAP_CONTINUATIONS
+void grow_throw(a) /* Grow the stack so that there is room */
+ long *a; /* to copy in the continuation. Then */
+{ /* retry the throw. */
+ long growth[100];
+ growth[0] = a[0];
+ growth[1] = a[1];
+ growth[2] = a[2] + 1;
+ growth[3] = (long) a;
+ growth[99] = sizeof growth;
+ dynthrow(growth);
+}
+#endif /* ndef CHEAP_CONTINUATIONS */
+
+/* throw_to_continuation() restores the stack in effect when
+ @var{cont} was made and resumes @var{cont}'s processor state. If
+ the stack cannot be resotred because @var{cont} and @var{root_cont}
+ do not have the same stkbase, @code{throw_to_continuation()
+ returns. */
+
+/* Note: If 2 or more @var{cont}s share a parent continuation and if
+ the values of stack allocated variables in that parent continuation
+ are changed, the results are unspecified. This is because the
+ parent continuation may or may not be reloaded, depending on what
+ other throws have intervened. */
+
+void throw_to_continuation(cont, val, root_cont)
+ CONTINUATION *cont;
+ long val;
+ CONTINUATION *root_cont;
+{
+ long a[3];
+ a[0] = (long)cont;
+ a[1] = val;
+ a[2] = 0;
+ if (cont->stkbse != root_cont->stkbse)
+ return; /* Stale continuation */
+ dynthrow(a);
+}
diff --git a/continue.h b/continue.h
new file mode 100644
index 0000000..3309172
--- /dev/null
+++ b/continue.h
@@ -0,0 +1,178 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "continue.h" Scheme Continuations for C.
+ Author: Aubrey Jaffer. */
+
+#ifdef vms
+# ifndef CHEAP_CONTINUATIONS
+
+ typedef int jmp_buf[17];
+ extern int setjump(jmp_buf env);
+ extern int longjump(jmp_buf env, int ret);
+
+# define setjmp setjump
+# define longjmp longjump
+# else
+# include <setjmp.h>
+# endif
+#else /* ndef vms */
+# ifdef _CRAY1
+ typedef int jmp_buf[112];
+ extern int setjump(jmp_buf env);
+ extern int longjump(jmp_buf env, int ret);
+
+# define setjmp setjump
+# define longjmp longjump
+# else /* ndef _CRAY1 */
+# include <setjmp.h>
+# endif /* ndef _CRAY1 */
+#endif /* ndef vms */
+
+/* `other' is a CONTINUATION slot for miscellaneous data of type
+ CONTINUATION_OTHER. */
+
+#ifndef CONTINUATION_OTHER
+# define CONTINUATION_OTHER int
+#endif
+
+/* If stack is not longword aligned then */
+
+/* #define SHORT_ALIGN */
+#ifdef THINK_C
+# define SHORT_ALIGN
+#endif
+#ifdef MSDOS
+# define SHORT_ALIGN
+#endif
+#ifdef atarist
+# define SHORT_ALIGN
+#endif
+
+#ifdef SHORT_ALIGN
+typedef short STACKITEM;
+#else
+typedef long STACKITEM;
+#endif
+
+struct Continuation {jmp_buf jmpbuf;
+ long thrwval;
+ long length;
+ STACKITEM *stkbse;
+ CONTINUATION_OTHER other;
+ struct Continuation *parent;
+ };
+typedef struct Continuation CONTINUATION;
+
+#ifndef P
+# ifdef USE_ANSI_PROTOTYPES
+# define P(s) s
+# else
+# define P(s) ()
+# endif
+#endif
+
+extern long thrown_value;
+long stack_size P((STACKITEM *start));
+CONTINUATION *make_root_continuation P((STACKITEM *stack_base));
+CONTINUATION *make_continuation P((CONTINUATION *parent_cont));
+void free_continuation P((CONTINUATION *cont));
+void dynthrow P((long *a));
+void grow_throw P((long *a));
+void throw_to_continuation P((CONTINUATION *cont, long val,
+ CONTINUATION *root_cont));
+
+/* how to get the local definition for malloc */
+
+#ifndef STDC_HEADERS
+# ifndef malloc
+ char *malloc P((sizet size));
+# endif
+ char *realloc P((char *ptr, sizet size));
+#endif
+
+/* PTR_LT defines how to compare two addresses (which may not be in
+ the same array). */
+
+#if defined(__TURBOC__) && !defined(__TOS__)
+# ifdef PROT386
+# define PTR_LT(x, y) (((long)(x)) < ((long)(y)))
+# else
+# define PTR_LT(x, y) ((x) < (y))
+# endif
+#else /* not __TURBOC__ */
+# ifdef nosve
+# define PTR_MASK 0xffffffffffff
+# define PTR_LT(x, y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK))
+# else
+# define PTR_LT(x, y) ((x) < (y))
+# endif
+#endif
+
+#define PTR_GT(x, y) PTR_LT(y, x)
+#define PTR_LE(x, y) (!PTR_GT(x, y))
+#define PTR_GE(x, y) (!PTR_LT(x, y))
+
+/* James Clark came up with this neat one instruction fix for
+ continuations on the SPARC. It flushes the register windows so
+ that all the state of the process is contained in the stack. */
+
+#ifdef sparc
+# define FLUSH_REGISTER_WINDOWS asm("ta 3")
+#else
+# define FLUSH_REGISTER_WINDOWS /* empty */
+#endif
+
+/* If stacks grow up then */
+
+/* #define STACK_GROWS_UP */
+#ifdef hp9000s800
+# define STACK_GROWS_UP
+#endif
+#ifdef pyr
+# define STACK_GROWS_UP
+#endif
+#ifdef nosve
+# define STACK_GROWS_UP
+#endif
+#ifdef _UNICOS
+# define STACK_GROWS_UP
+#endif
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 <curses.h>
+
+#ifdef MWC
+# include <unctrl.h>
+#endif
+
+#ifndef STDC_HEADERS
+ int wrefresh P((WINDOW *));
+ int wgetch P((WINDOW *));
+#endif
+
+/* define WIN port type */
+#define WIN(obj) ((WINDOW*)CDR(obj))
+#define WINP(obj) (tc16_window==TYP16(obj))
+int freewindow(win)
+ WINDOW *win;
+{
+ if (win==stdscr) return 0;
+ delwin(win);
+ return 0;
+}
+int prinwindow(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ prinport(exp, port, "window");
+ return !0;
+}
+int bwaddch(c, win) int c; WINDOW *win; {waddch(win, c);return c;}
+int bwaddstr(str, win) char *str; WINDOW *win; {waddstr(win, str);return 0;}
+sizet bwwrite(str, siz, num, win)
+ sizet siz, num;
+ char *str; WINDOW *win;
+{
+ sizet i = 0, prod = siz*num;
+ for (;i < prod;i++) waddch(win, str[i]);
+ return num;
+}
+int tc16_window;
+static ptobfuns winptob = {
+ mark0,
+ freewindow,
+ prinwindow,
+ equal0,
+ bwaddch,
+ bwaddstr,
+ bwwrite,
+ wrefresh,
+ wgetch,
+ freewindow};
+
+SCM mkwindow(win)
+ WINDOW *win;
+{
+ SCM z;
+ if (NULL==win) return BOOL_F;
+ NEWCELL(z);
+ DEFER_INTS;
+ SETCHARS(z, win);
+ CAR(z) = tc16_window | OPN | RDNG | WRTNG;
+ ALLOW_INTS;
+ return z;
+}
+
+SCM *loc_stdscr = 0;
+SCM linitscr()
+{
+ WINDOW *win;
+ if NIMP(*loc_stdscr) {
+ refresh();
+ return *loc_stdscr;
+ }
+ win = initscr();
+ return *loc_stdscr = mkwindow(win);
+}
+SCM lendwin()
+{
+ if IMP(*loc_stdscr) return BOOL_F;
+ return ERR==endwin() ? BOOL_F : BOOL_T;
+}
+
+static char s_newwin[] = "newwin", s_subwin[] = "subwin", s_mvwin[] = "mvwin",
+ s_overlay[] = "overlay", s_overwrite[] = "overwrite";
+SCM lnewwin(lines, cols, args)
+ SCM lines, cols, args;
+{
+ SCM begin_y, begin_x;
+ WINDOW *win;
+ ASSERT(INUMP(lines), lines, ARG1, s_newwin);
+ ASSERT(INUMP(cols), cols, ARG2, s_newwin);
+ ASSERT(2==ilength(args), args, WNA, s_newwin);
+ begin_y = CAR(args);
+ begin_x = CAR(CDR(args));
+ ASSERT(INUMP(begin_y), begin_y, ARG3, s_newwin);
+ ASSERT(INUMP(begin_x), begin_y, ARG4, s_newwin);
+ win = newwin(INUM(lines), INUM(cols),
+ INUM(begin_y), INUM(begin_x));
+ return mkwindow(win);
+}
+
+SCM lmvwin(win, y, x)
+ SCM win, y, x;
+{
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_mvwin);
+ ASSERT(INUMP(x), x, ARG2, s_mvwin);
+ ASSERT(INUMP(y), y, ARG3, s_mvwin);
+ return ERR==mvwin(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T;
+}
+
+SCM lsubwin(win, lines, args)
+ SCM win, lines, args;
+{
+ SCM cols, begin_y, begin_x;
+ WINDOW *nwin;
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_subwin);
+ ASSERT(INUMP(lines), lines, ARG2, s_subwin);
+ ASSERT(3==ilength(args), args, WNA, s_subwin);
+ cols = CAR(args);
+ args = CDR(args);
+ begin_y = CAR(args);
+ begin_x = CAR(CDR(args));
+ ASSERT(INUMP(cols), cols, ARG3, s_subwin);
+ ASSERT(INUMP(begin_y), begin_y, ARG3, s_subwin);
+ ASSERT(INUMP(begin_x), begin_y, ARG4, s_subwin);
+ nwin = subwin(WIN(win), INUM(lines), INUM(cols),
+ INUM(begin_y), INUM(begin_x));
+ return mkwindow(nwin);
+}
+
+SCM loverlay(srcwin, dstwin)
+ SCM srcwin, dstwin;
+{
+ ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overlay);
+ ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overlay);
+ return ERR==overlay(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T;
+}
+
+SCM loverwrite(srcwin, dstwin)
+ SCM srcwin, dstwin;
+{
+ ASSERT(NIMP(srcwin) && WINP(srcwin), srcwin, ARG1, s_overwrite);
+ ASSERT(NIMP(dstwin) && WINP(dstwin), dstwin, ARG2, s_overwrite);
+ return ERR==overwrite(WIN(srcwin), WIN(dstwin)) ? BOOL_F : BOOL_T;
+}
+
+static char s_wmove[] = "wmove", s_wadd[] = "wadd", s_winsert[] = "winsert",
+ s_box[] = "box";
+SCM lwmove(win, y, x)
+ SCM win, y, x;
+{
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wmove);
+ ASSERT(INUMP(x), x, ARG2, s_wmove);
+ ASSERT(INUMP(y), y, ARG3, s_wmove);
+ return ERR==wmove(WIN(win), INUM(y), INUM(x)) ? BOOL_F : BOOL_T;
+}
+
+SCM lwadd(win, obj)
+ SCM win, obj;
+{
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_wadd);
+ if ICHRP(obj)
+ return ERR==waddch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T;
+ if INUMP(obj)
+ return ERR==waddch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T;
+ ASSERT(NIMP(obj) && STRINGP(obj), obj, ARG2, s_wadd);
+ return ERR==waddstr(WIN(win), CHARS(obj)) ? BOOL_F : BOOL_T;
+}
+
+SCM lwinsert(win, obj)
+ SCM win, obj;
+{
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winsert);
+ if INUMP(obj)
+ return ERR==winsch(WIN(win), INUM(obj)) ? BOOL_F : BOOL_T;
+ ASSERT(ICHRP(obj), obj, ARG2, s_winsert);
+ return ERR==winsch(WIN(win), ICHR(obj)) ? BOOL_F : BOOL_T;
+}
+
+SCM lbox(win, vertch, horch)
+ SCM win, vertch, horch;
+{
+ int v, h;
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_box);
+ if INUMP(vertch) v = INUM(vertch);
+ else {
+ ASSERT(ICHRP(vertch), vertch, ARG2, s_box);
+ v = ICHR(vertch);
+ }
+ if INUMP(horch) h = INUM(horch);
+ else {
+ ASSERT(ICHRP(horch), horch, ARG3, s_box);
+ h = ICHR(horch);
+ }
+ return ERR==box(WIN(win), v, h) ? BOOL_F : BOOL_T;
+}
+
+static char s_getyx[] = "getyx", s_winch[] = "winch", s_unctrl[] = "unctrl";
+SCM lgetyx(win)
+ SCM win;
+{
+ int y, x;
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_getyx);
+ getyx(WIN(win), y, x);
+ return cons2(MAKINUM(y), MAKINUM(x), EOL);
+}
+
+SCM lwinch(win)
+ SCM win;
+{
+ ASSERT(NIMP(win) && WINP(win), win, ARG1, s_winch);
+ return MAKICHR(winch(WIN(win)));
+}
+
+SCM lunctrl(c)
+ SCM c;
+{
+ ASSERT(ICHRP(c), c, ARG1, s_unctrl);
+ {
+ char *str = unctrl(ICHR(c));
+ return makfrom0str(str);
+ }
+}
+static char s_owidth[] = "output-port-width";
+static char s_oheight[] = "output-port-height";
+SCM owidth(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) arg = cur_outp;
+ ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
+ if NIMP(*loc_stdscr)
+ if WINP(arg) return MAKINUM(WIN(arg)->_maxx+1);
+ else return MAKINUM(COLS);
+ return MAKINUM(80);
+}
+SCM oheight(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) arg = cur_outp;
+ ASSERT(NIMP(arg) && OPOUTPORTP(arg), arg, ARG1, s_owidth);
+ if NIMP(*loc_stdscr)
+ if WINP(arg) return MAKINUM(WIN(arg)->_maxy+1);
+ else return MAKINUM(LINES);
+ return MAKINUM(24);
+}
+SCM lrefresh()
+{
+ return MAKINUM(wrefresh(curscr));
+}
+
+#define SUBR0(lname, name) SCM lname(){name();return UNSPECIFIED;}
+SUBR0(lnl, nl)
+SUBR0(lnonl, nonl)
+SUBR0(lcbreak, cbreak)
+SUBR0(lnocbreak, nocbreak)
+SUBR0(lecho, echo)
+SUBR0(lnoecho, noecho)
+SUBR0(lraw, raw)
+SUBR0(lnoraw, noraw)
+SUBR0(lsavetty, savetty)
+SUBR0(lresetty, resetty)
+
+static char s_nonl[] = "nonl", s_nocbreak[] = "nocbreak",
+ s_noecho[] = "noecho", s_noraw[] = "noraw";
+
+static iproc subr0s[] = {
+ {"initscr", linitscr},
+ {"endwin", lendwin},
+ {&s_nonl[2], lnl},
+ {s_nonl, lnonl},
+ {&s_nocbreak[2], lcbreak},
+ {s_nocbreak, lnocbreak},
+ {&s_noecho[2], lecho},
+ {s_noecho, lnoecho},
+ {&s_noraw[2], lraw},
+ {s_noraw, lnoraw},
+ {"resetty", lresetty},
+ {"savetty", lsavetty},
+ {"refresh", lrefresh},
+ {0, 0}};
+
+#define SUBRW(ln, n, s_n, sn) static char s_n[]=sn;\
+ SCM ln(w)SCM w;\
+ {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\
+ return ERR==n(WIN(w))?BOOL_F:BOOL_T;}
+
+SUBRW(lwerase, werase, s_werase, "werase")
+SUBRW(lwclear, wclear, s_wclear, "wclear")
+SUBRW(lwclrtobot, wclrtobot, s_wclrtobot, "wclrtobot")
+SUBRW(lwclrtoeol, wclrtoeol, s_wclrtoeol, "wclrtoeol")
+SUBRW(lwdelch, wdelch, s_wdelch, "wdelch")
+SUBRW(lwdeleteln, wdeleteln, s_wdeleteln, "wdeleteln")
+SUBRW(lwinsertln, winsertln, s_winsertln, "winsertln")
+SUBRW(lscroll, scroll, s_scroll, "scroll")
+SUBRW(ltouchwin, touchwin, s_touchwin, "touchwin")
+SUBRW(lwstandout, wstandout, s_wstandout, "wstandout")
+SUBRW(lwstandend, wstandend, s_wstandend, "wstandend")
+
+static iproc subr1s[] = {
+ {s_werase, lwerase},
+ {s_wclear, lwclear},
+ {s_wclrtobot, lwclrtobot},
+ {s_wclrtoeol, lwclrtoeol},
+ {s_wdelch, lwdelch},
+ {s_wdeleteln, lwdeleteln},
+ {s_winsertln, lwinsertln},
+ {s_scroll, lscroll},
+ {s_touchwin, ltouchwin},
+ {s_wstandout, lwstandout},
+ {s_wstandend, lwstandend},
+ {s_getyx, lgetyx},
+ {s_winch, lwinch},
+ {s_unctrl, lunctrl},
+ {0, 0}};
+
+#define SUBROPT(ln, n, s_n, sn) static char s_n[]=sn;\
+ SCM ln(w, b)SCM w, b;\
+ {ASSERT(NIMP(w) && WINP(w), w, ARG1, sn);\
+ return ERR==n(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;}
+
+/* SUBROPT(lclearok, clearok, s_clearok, "clearok") */
+/* SUBROPT(lidlok, idlok, s_idlok, "idlok") */
+SUBROPT(lleaveok, leaveok, s_leaveok, "leaveok")
+SUBROPT(lscrollok, scrollok, s_scrollok, "scrollok")
+/* SUBROPT(lnodelay, nodelay, s_nodelay, "nodelay") */
+
+static char s_clearok[] = "clearok";
+SCM lclearok(w, b) SCM w, b;
+{
+ if (BOOL_T==w) return ERR==clearok(curscr, BOOL_F != b)?BOOL_F:BOOL_T;
+ ASSERT(NIMP(w) && WINP(w), w, ARG1, s_clearok);
+ return ERR==clearok(WIN(w), BOOL_F != b)?BOOL_F:BOOL_T;
+}
+
+static iproc subr2s[] = {
+ {s_overlay, loverlay},
+ {s_overwrite, loverwrite},
+ {s_wadd, lwadd},
+ {s_winsert, lwinsert},
+ {s_clearok, lclearok},
+ /* {s_idlok, lidlok}, */
+ {s_leaveok, lleaveok},
+ {s_scrollok, lscrollok},
+/* {s_nodelay, lnodelay}, */
+ {0, 0}};
+
+void init_crs()
+{
+ /* savetty(); */
+ /* "Stdscr" is a nearly inaccessible symbol used as a GC protect. */
+ loc_stdscr = &CDR(sysintern("Stdscr", UNDEFINED));
+ tc16_window = newptob(&winptob);
+
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+
+ make_subr(s_owidth, tc7_subr_1o, owidth);
+ make_subr(s_oheight, tc7_subr_1o, oheight);
+
+ make_subr(s_newwin, tc7_lsubr_2, lnewwin);
+ make_subr(s_subwin, tc7_lsubr_2, lsubwin);
+
+ make_subr(s_wmove, tc7_subr_3, lwmove);
+ make_subr(s_mvwin, tc7_subr_3, lmvwin);
+ make_subr(s_box, tc7_subr_3, lbox);
+ add_feature("curses");
+ add_final(lendwin);
+}
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("#<shl ", port);
+ intprint(CDR(exp), 16, port);
+ lputc('>', port);
+ return 1;
+}
+int tc16_shl;
+static smobfuns shlsmob = {mark0, free0, prinshl};
+
+static char s_link[] = "dyn:link", s_call[] = "dyn:call";
+SCM l_dyn_link(fname)
+ SCM fname;
+{
+ SCM z;
+ shl_t shl;
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ DEFER_INTS;
+ shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
+ if (NULL==shl) {
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ NEWCELL(z);
+ SETCHARS(z, shl);
+ CAR(z) = tc16_shl;
+ ALLOW_INTS;
+/* linkpath = fname; */
+ return z;
+}
+SCM l_dyn_call(symb, shl)
+ SCM symb, shl;
+{
+ void (*func)() = 0;
+ int i;
+/* SCM oloadpath = *loc_loadpath; */
+ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ DEFER_INTS;
+ if ((i = shl_findsym(&SHL(shl),
+ CHARS(symb),
+ TYPE_PROCEDURE, &func)) != 0) {
+ puts(" undef:"); puts(CHARS(symb));
+ }
+ ALLOW_INTS;
+ if (i != 0) return BOOL_F;
+/* *loc_loadpath = linkpath; */
+ (*func) ();
+/* *loc_loadpath = oloadpath; */
+ return BOOL_T;
+}
+
+static char s_main_call[] = "dyn:main-call";
+SCM l_dyn_main_call(symb, shl, args)
+ SCM symb, shl, args;
+{
+ int i;
+ int (*func)P((int argc, char **argv)) = 0;
+ char **argv;
+/* SCM oloadpath = *loc_loadpath; */
+ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+ DEFER_INTS;
+ if ((i = shl_findsym(&SHL(shl),
+ CHARS(symb),
+ TYPE_PROCEDURE, &func)) != 0) {
+ puts(" undef:"); puts(CHARS(symb));
+ }
+ argv = makargvfrmstrs(args, s_main_call);
+ ALLOW_INTS;
+ if (i != 0) return BOOL_F;
+/* *loc_loadpath = linkpath; */
+ i = (*func) ((int)ilength(args), argv);
+/* *loc_loadpath = oloadpath; */
+ DEFER_INTS;
+ must_free_argv(argv);
+ ALLOW_INTS;
+ return MAKINUM(0L+i);
+}
+
+static char s_unlink[] = "dyn:unlink";
+SCM l_dyn_unlink(shl)
+ SCM shl;
+{
+ int status;
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ DEFER_INTS;
+ status = shl_unload(SHL(shl));
+ ALLOW_INTS;
+ if (!status) return BOOL_T;
+ return BOOL_F;
+}
+static iproc subr1s[] = {
+ {s_link, l_dyn_link},
+ {s_unlink, l_dyn_unlink},
+ {0, 0}};
+void init_dynl()
+{
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+ add_feature("shl");
+}
+# endif
+#endif
+
+#ifdef vms
+/* This permits dynamic linking. For example, the procedure of 0 arguments
+ from a file could be the initialization procedure.
+ (vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO")
+ The first argument specifies the directory where the file specified
+ by the second argument resides. The current directory would be
+ "SYS$DISK:[].EXE".
+ The second argument cannot contain any punctuation.
+ The third argument probably needs to be uppercased to mimic the VMS linker.
+ */
+
+# include <descrip.h>
+# include <ssdef.h>
+# include <rmsdef.h>
+
+struct dsc$descriptor *descriptorize(x, buff)
+ struct dsc$descriptor *x;
+ SCM buff;
+{(*x).dsc$w_length = LENGTH(buff);
+ (*x).dsc$a_pointer = CHARS(buff);
+ (*x).dsc$b_class = DSC$K_CLASS_S;
+ (*x).dsc$b_dtype = DSC$K_DTYPE_T;
+ return(x);}
+
+static char s_dynl[] = "vms:dynamic-link-call";
+SCM dynl(dir, symbol, fname)
+ SCM dir, symbol, fname;
+{
+ struct dsc$descriptor fnamed, symbold, dird;
+ void (*fcn)();
+ long retval;
+ ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
+ ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
+ descriptorize(&fnamed, fname);
+ descriptorize(&symbold, symbol);
+ DEFER_INTS;
+ retval = lib$find_image_symbol(&fnamed, &symbold, &fcn,
+ IMP(dir) ? 0 : descriptorize(&dird, dir));
+ if (SS$_NORMAL != retval) {
+ /* wta(MAKINUM(retval), "vms error", s_dynl); */
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ ALLOW_INTS;
+/* *loc_loadpath = dir; */
+ (*fcn)();
+/* *loc_loadpath = oloadpath; */
+ return BOOL_T;
+}
+
+void init_dynl()
+{
+ make_subr(s_dynl, tc7_subr_3, dynl);
+}
+#endif
+
+
+#ifdef SUN_DL
+# include <dlfcn.h>
+
+# define SHL(obj) ((void*)CDR(obj))
+
+# ifdef SVR4 /* Solaris 2. */
+# define DLOPEN_MODE RTLD_LAZY
+# else
+# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
+# endif
+
+sizet frshl(ptr)
+ CELLPTR ptr;
+{
+# if 0
+ /* Should freeing a shl close and possibly unmap the object file it */
+ /* refers to? */
+ if(SHL(ptr))
+ dlclose(SHL(ptr));
+# endif
+ return 0;
+}
+
+int prinshl(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<shl ", port);
+ intprint(CDR(exp), 16, port);
+ lputc('>', port);
+ return 1;
+}
+int tc16_shl;
+static smobfuns shlsmob = {mark0, frshl, prinshl};
+
+static char s_link[] = "dyn:link", s_call[] = "dyn:call";
+SCM l_dyn_link(fname)
+ SCM fname;
+{
+ SCM z;
+ void *handle;
+ if FALSEP(fname) return fname;
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+ DEFER_INTS;
+ handle = dlopen(CHARS(fname), DLOPEN_MODE);
+ if (NULL==handle) {
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ NEWCELL(z);
+ SETCHARS(z, handle);
+ CAR(z) = tc16_shl;
+ ALLOW_INTS;
+/* linkpath = fname; */
+ return z;
+}
+
+SCM l_dyn_call(symb, shl)
+ SCM symb, shl;
+{
+ void (*func)() = 0;
+/* SCM oloadpath = *loc_loadpath; */
+ ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+ DEFER_INTS;
+ func = dlsym(SHL(shl), CHARS(symb));
+ if (!func) {
+ const char *dlr = dlerror();
+ ALLOW_INTS;
+ if (dlr) puts(dlr);
+ return BOOL_F;
+ }
+ ALLOW_INTS;
+/* *loc_loadpath = linkpath; */
+ (*func) ();
+/* *loc_loadpath = oloadpath; */
+ return BOOL_T;
+}
+static char s_unlink[] = "dyn:unlink";
+SCM l_dyn_unlink(shl)
+ SCM shl;
+{
+ int status;
+ ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+ DEFER_INTS;
+ status = dlclose(SHL(shl));
+ SETCHARS(shl, NULL);
+ ALLOW_INTS;
+ if (!status) return BOOL_T;
+ return BOOL_F;
+}
+static iproc subr1s[] = {
+{s_link, l_dyn_link},
+{s_unlink, l_dyn_unlink},
+{0, 0}};
+
+void init_dynl()
+{
+ tc16_shl = newsmob(&shlsmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_call, tc7_subr_2, l_dyn_call);
+ add_feature("sun-dl");
+}
+#endif /* SUN_DL */
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 <config.h>
+#endif
+
+/* ******** WARNING ********
+ Do not insert any data definitions before data_start!
+ Since this is the first file linked, the address of the following
+ variable should correspond to the start of initialized data space.
+ On some systems this is a constant that is independent of the text
+ size for shared executables. On others, it is a function of the
+ text size. In short, this seems to be the most portable way to
+ discover the start of initialized data space dynamically at runtime,
+ for either shared or unshared executables, on either swapping or
+ virtual systems. It only requires that the linker allocate objects
+ in the order encountered, a reasonable model for most Unix systems.
+ Similarly, note that the address of _start() should be the start
+ of text space. Fred Fish, UniSoft Systems Inc. */
+
+int data_start = 0;
+
+#ifdef NEED_ERRNO
+int errno;
+#endif
+
+#ifndef DONT_NEED_ENVIRON
+char **environ;
+#endif
+
+#ifndef static
+/* On systems where the static storage class is usable, this function
+ should be declared as static. Otherwise, the static keyword has
+ been defined to be something else, and code for those systems must
+ take care of this declaration appropriately. */
+static start1 ();
+#endif
+
+#ifdef APOLLO
+extern char *malloc(), *realloc(), *(*_libc_malloc) (), *(*_libc_realloc)();
+extern void free(), (*_libc_free) (); extern int main();
+std_$call void unix_$main();
+
+_start()
+{
+ _libc_malloc = malloc;
+ _libc_realloc = realloc;
+ _libc_free = free;
+ unix_$main(main); /* no return */
+}
+#endif /* APOLLO */
+
+#if defined(orion) || defined(pyramid) || defined(celerity) || defined(ALLIANT) || defined(clipper) || defined(sps7)
+
+#if defined(sps7) && defined(V3x)
+ asm(" section 10");
+ asm(" ds.b 0xb0");
+#endif
+
+#ifdef ALLIANT
+/* _start must initialize _curbrk and _minbrk on the first startup;
+ when starting up after dumping, it must initialize them to what they were
+ before the dumping, since they are in the shared library and
+ are not dumped. See ADJUST_EXEC_HEADER in m-alliant.h. */
+extern unsigned char *_curbrk, *_minbrk;
+extern unsigned char end;
+unsigned char *_setbrk = &end;
+#ifdef ALLIANT_2800
+unsigned char *_end = &end;
+#endif
+#endif
+
+#ifndef DUMMIES
+#define DUMMIES
+#endif
+
+_start (DUMMIES argc, argv, envp)
+ int argc;
+ char **argv, **envp;
+{
+#ifdef ALLIANT
+#ifdef ALLIANT_2800
+ _curbrk = _end;
+ _minbrk = _end;
+#else
+ _curbrk = _setbrk;
+ _minbrk = _setbrk;
+#endif
+#endif
+
+ environ = envp;
+
+ exit (main (argc, argv, envp));
+}
+
+#endif /* orion or pyramid or celerity or alliant or clipper */
+
+#if defined (ns16000) && !defined (sequent) && !defined (UMAX) && !defined (CRT0_DUMMIES)
+
+_start ()
+{
+/* On 16000, _start pushes fp onto stack */
+ start1 ();
+}
+
+/* ignore takes care of skipping the fp value pushed in start. */
+static
+start1 (ignore, argc, argv)
+ int ignore;
+ int argc;
+ register char **argv;
+{
+ environ = argv + argc + 1;
+
+ if (environ == *argv)
+ environ--;
+ exit (main (argc, argv, environ));
+}
+#endif /* ns16000, not sequent and not UMAX, and not the CRT0_DUMMIES method */
+
+#ifdef UMAX
+_start()
+{
+ asm(" exit [] # undo enter");
+ asm(" .set exitsc,1");
+ asm(" .set sigcatchall,0x400");
+
+ asm(" .globl _exit");
+ asm(" .globl start");
+ asm(" .globl __start");
+ asm(" .globl _main");
+ asm(" .globl _environ");
+ asm(" .globl _sigvec");
+ asm(" .globl sigentry");
+
+ asm("start:");
+ asm(" br .xstart");
+ asm(" .org 0x20");
+ asm(" .double p_glbl,0,0xf00000,0");
+ asm(" .org 0x30");
+ asm(".xstart:");
+ asm(" adjspb $8");
+ asm(" movd 8(sp),0(sp) # argc");
+ asm(" addr 12(sp),r0");
+ asm(" movd r0,4(sp) # argv");
+ asm("L1:");
+ asm(" movd r0,r1");
+ asm(" addqd $4,r0");
+ asm(" cmpqd $0,0(r1) # null args term ?");
+ asm(" bne L1");
+ asm(" cmpd r0,0(4(sp)) # end of 'env' or 'argv' ?");
+ asm(" blt L2");
+ asm(" addqd $-4,r0 # envp's are in list");
+ asm("L2:");
+ asm(" movd r0,8(sp) # env");
+ asm(" movd r0,@_environ # indir is 0 if no env ; not 0 if env");
+ asm(" movqd $0,tos # setup intermediate signal handler");
+ asm(" addr @sv,tos");
+ asm(" movzwd $sigcatchall,tos");
+ asm(" jsr @_sigvec");
+ asm(" adjspb $-12");
+ asm(" jsr @_main");
+ asm(" adjspb $-12");
+ asm(" movd r0,tos");
+ asm(" jsr @_exit");
+ asm(" adjspb $-4");
+ asm(" addr @exitsc,r0");
+ asm(" svc");
+ asm(" .align 4 # sigvec arg");
+ asm("sv:");
+ asm(" .double sigentry");
+ asm(" .double 0");
+ asm(" .double 0");
+
+ asm(" .comm p_glbl,1");
+}
+#endif /* UMAX */
+
+#ifdef CRT0_DUMMIES
+
+/* Define symbol "start": here; some systems want that symbol. */
+#ifdef DOT_GLOBAL_START
+asm(" .text ");
+asm(" .globl start ");
+asm(" start: ");
+#endif /* DOT_GLOBAL_START */
+
+#ifdef NODOT_GLOBAL_START
+asm(" text ");
+asm(" global start ");
+asm(" start: ");
+#endif /* NODOT_GLOBAL_START */
+
+#ifdef m68000
+
+/* GCC 2.1, when optimization is turned off, seems to want to push a
+ word of garbage on the stack, which screws up the CRT0_DUMMIES
+ hack. So we hand-code _start in assembly language. */
+asm(".text ");
+asm(" .even ");
+asm(".globl __start ");
+asm("__start: ");
+asm(" link a6,#0 ");
+asm(" jbsr _start1 ");
+asm(" unlk a6 ");
+asm(" rts ");
+
+#else /* not m68000 */
+
+_start ()
+{
+/* On vax, nothing is pushed here */
+/* On sequent, bogus fp is pushed here */
+ start1 ();
+}
+
+#endif /* possibly m68000 */
+
+static
+start1 (CRT0_DUMMIES argc, xargv)
+ int argc;
+ char *xargv;
+{
+ register char **argv = &xargv;
+ environ = argv + argc + 1;
+
+ if ((char *)environ == xargv)
+ environ--;
+ exit (main (argc, argv, environ));
+
+ /* Refer to `start1' so GCC will not think it is never called
+ and optimize it out. */
+ (void) &start1;
+}
+#else /* not CRT0_DUMMIES */
+
+/* "m68k" and "m68000" both stand for m68000 processors,
+ but with different program-entry conventions.
+ This is a kludge. Now that the CRT0_DUMMIES mechanism above exists,
+ most of these machines could use the vax code above
+ with some suitable definition of CRT0_DUMMIES.
+ Then the symbol m68k could be flushed.
+ But I don't want to risk breaking these machines
+ in a version 17 patch release, so that change is being put off. */
+
+#ifdef m68k /* Can't do it all from C */
+ asm (" global _start");
+ asm (" text");
+ asm ("_start:");
+#ifndef NU
+#ifdef STRIDE
+ asm (" comm havefpu%,2");
+#else /* m68k, not STRIDE */
+ asm (" comm splimit%,4");
+#endif /* STRIDE */
+ asm (" global exit");
+ asm (" text");
+#ifdef STRIDE
+ asm (" trap &3");
+ asm (" mov.w %d0,havefpu%");
+#else /* m68k, not STRIDE */
+ asm (" mov.l %d0,splimit%");
+#endif /* STRIDE */
+#endif /* not NU */
+ asm (" jsr start1");
+ asm (" mov.l %d0,(%sp)");
+ asm (" jsr exit");
+ asm (" mov.l &1,%d0"); /* d0 = 1 => exit */
+ asm (" trap &0");
+#else /* m68000, not m68k */
+
+#ifdef m68000
+
+#ifdef ISI68K
+/* Added by ESM Sun May 24 12:44:02 1987 to get new ISI library to work */
+/* Edited by Ray Mon May 15 15:59:56 EST 1989 so we can compile with gcc */
+#if defined(BSD4_3) && !defined(__GNUC__)
+static foo () {
+#endif
+ asm (" .globl is68020");
+ asm ("is68020:");
+#ifndef BSD4_3
+ asm (" .long 0x00000000");
+ asm (" .long 0xffffffff");
+/* End of stuff added by ESM */
+#endif
+ asm (" .text");
+ asm (" .globl __start");
+ asm ("__start:");
+ asm (" .word 0");
+ asm (" link a6,#0");
+ asm (" jbsr _start1");
+ asm (" unlk a6");
+ asm (" rts");
+#if defined(BSD4_3) && !defined(__GNUC__)
+ }
+#endif
+#else /* not ISI68K */
+
+_start ()
+{
+#ifdef sun
+#ifdef LISP_FLOAT_TYPE
+ finitfp_();
+#endif
+#endif
+/* On 68000, _start pushes a6 onto stack */
+ start1 ();
+}
+#endif /* not ISI68k */
+#endif /* m68000 */
+#endif /* m68k */
+
+#if defined(m68k) || defined(m68000)
+/* ignore takes care of skipping the a6 value pushed in start. */
+static
+#if defined(m68k)
+start1 (argc, xargv)
+#else
+start1 (ignore, argc, xargv)
+#endif
+ int argc;
+ char *xargv;
+{
+ register char **argv = &xargv;
+ environ = argv + argc + 1;
+
+ if ((char *)environ == xargv)
+ environ--;
+#ifdef sun_68881
+ asm(" jsr f68881_used");
+#endif
+#ifdef sun_fpa
+ asm(" jsr ffpa_used");
+#endif
+#ifdef sun_soft
+ asm(" jsr start_float");
+#endif
+ exit (main (argc, argv, environ));
+}
+
+#endif /* m68k or m68000 */
+
+#endif /* not CRT0_DUMMIES */
+
+#ifdef hp9000s300
+int argc_value;
+char **argv_value;
+#ifdef OLD_HP_ASSEMBLER
+ asm(" text");
+ asm(" globl __start");
+ asm(" globl _exit");
+ asm(" globl _main");
+ asm("__start");
+ asm(" dc.l 0");
+ asm(" subq.w #0x1,d0");
+ asm(" move.w d0,float_soft");
+ asm(" move.l 0x4(a7),d0");
+ asm(" beq.s skip_1");
+ asm(" move.l d0,a0");
+ asm(" clr.l -0x4(a0)");
+ asm("skip_1");
+ asm(" move.l a7,a0");
+ asm(" subq.l #0x8,a7");
+ asm(" move.l (a0),(a7)");
+ asm(" move.l (a0),_argc_value");
+ asm(" addq.l #0x4,a0");
+ asm(" move.l a0,0x4(a7)");
+ asm(" move.l a0,_argv_value");
+ asm("incr_loop");
+ asm(" tst.l (a0)+");
+ asm(" bne.s incr_loop");
+ asm(" move.l 0x4(a7),a1");
+ asm(" cmp.l (a1),a0");
+ asm(" blt.s skip_2");
+ asm(" subq.l #0x4,a0");
+ asm("skip_2");
+ asm(" move.l a0,0x8(a7)");
+ asm(" move.l a0,_environ");
+ asm(" jsr _main");
+ asm(" addq.l #0x8,a7");
+ asm(" move.l d0,-(a7)");
+ asm(" jsr _exit");
+ asm(" move.w #0x1,d0");
+ asm(" trap #0x0");
+ asm(" comm float_soft,4");
+/* float_soft is allocated in this way because C would
+ put an underscore character in its name otherwise. */
+
+#else /* new hp assembler */
+
+ asm(" text");
+ asm(" global float_loc");
+ asm(" set float_loc,0xFFFFB000");
+ asm(" global fpa_loc");
+ asm(" set fpa_loc,0xfff08000");
+ asm(" global __start");
+ asm(" global _exit");
+ asm(" global _main");
+ asm("__start:");
+ asm(" byte 0,0,0,0");
+ asm(" subq.w &1,%d0");
+ asm(" mov.w %d0,float_soft");
+ asm(" mov.w %d1,flag_68881");
+#ifndef HPUX_68010
+ asm(" beq.b skip_float");
+ asm(" fmov.l &0x7400,%fpcr");
+/* asm(" fmov.l &0x7480,%fpcr"); */
+#endif /* HPUX_68010 */
+ asm("skip_float:");
+ asm(" mov.l %a0,%d0");
+ asm(" add.l %d0,%d0");
+ asm(" subx.w %d1,%d1");
+ asm(" mov.w %d1,flag_68010");
+ asm(" add.l %d0,%d0");
+ asm(" subx.w %d1,%d1");
+ asm(" mov.w %d1,flag_fpa");
+ asm(" tst.l %d2");
+ asm(" ble.b skip_3");
+ asm(" lsl flag_68881");
+ asm(" lsl flag_fpa");
+ asm("skip_3:");
+ asm(" mov.l 4(%a7),%d0");
+ asm(" beq.b skip_1");
+ asm(" mov.l %d0,%a0");
+ asm(" clr.l -4(%a0)");
+ asm("skip_1:");
+ asm(" mov.l %a7,%a0");
+ asm(" subq.l &8,%a7");
+ asm(" mov.l (%a0),(%a7)");
+ asm(" mov.l (%a0),_argc_value");
+ asm(" addq.l &4,%a0");
+ asm(" mov.l %a0,4(%a7)");
+ asm(" mov.l %a0,_argv_value");
+ asm("incr_loop:");
+ asm(" tst.l (%a0)+");
+ asm(" bne.b incr_loop");
+ asm(" mov.l 4(%a7),%a1");
+ asm(" cmp.l %a0,(%a1)");
+ asm(" blt.b skip_2");
+ asm(" subq.l &4,%a0");
+ asm("skip_2:");
+ asm(" mov.l %a0,8(%a7)");
+ asm(" mov.l %a0,_environ");
+ asm(" jsr _main");
+ asm(" addq.l &8,%a7");
+ asm(" mov.l %d0,-(%a7)");
+ asm(" jsr _exit");
+ asm(" mov.w &1,%d0");
+ asm(" trap &0");
+ asm(" comm float_soft, 4");
+ asm(" comm flag_68881, 4");
+ asm(" comm flag_68010, 4");
+ asm(" comm flag_68040, 4");
+ asm(" comm flag_fpa, 4");
+
+#endif /* new hp assembler */
+#endif /* hp9000s300 */
+
+#ifdef GOULD
+
+/* startup code has to be in near text rather
+ than fartext as allocated by the C compiler. */
+ asm(" .text");
+ asm(" .align 2");
+ asm(" .globl __start");
+ asm(" .text");
+ asm("__start:");
+/* setup base register b1 (function base). */
+ asm(" .using b1,.");
+ asm(" tpcbr b1");
+/* setup base registers b3 through b7 (data references). */
+ asm(" file basevals,b3");
+/* setup base register b2 (stack pointer); it should be
+ aligned on a 8-word boundary; but because it is pointing
+ to argc, its value should be remembered (in r5). */
+ asm(" movw b2,r4");
+ asm(" movw b2,r5");
+ asm(" andw #~0x1f,r4");
+ asm(" movw r4,b2");
+/* allocate stack frame to do some work. */
+ asm(" subea 16w,b2");
+/* initialize signal catching for UTX/32 1.2; this is
+ necessary to make restart from saved image work. */
+ asm(" movea sigcatch,r1");
+ asm(" movw r1,8w[b2]");
+ asm(" svc #1,#150");
+/* setup address of argc for start1. */
+ asm(" movw r5,8w[b2]");
+ asm(" func #1,_start1");
+ asm(" halt");
+/* space for ld to store base register initial values. */
+ asm(" .align 5");
+ asm("basevals:");
+ asm(" .word __base3,__base4,__base5,__base6,__base7");
+
+static
+start1 (xargc)
+ int *xargc;
+{
+ register int argc;
+ register char **argv;
+
+ argc = *xargc;
+ argv = (char **)(xargc) + 1;
+ environ = argv + argc + 1;
+
+ if (environ == argv)
+ environ--;
+ exit (main (argc, argv, environ));
+
+}
+
+#endif /* GOULD */
+
+#ifdef elxsi
+#include <elxsi/argvcache.h>
+
+extern char **environ;
+extern int errno;
+extern void _init_doscan(), _init_iob();
+extern char end[];
+char *_init_brk = end;
+
+_start()
+{
+ environ = exec_cache.ac_envp;
+ brk (_init_brk);
+ errno = 0;
+ _init_doscan ();
+ _init_iob ();
+ _exit (exit (main (exec_cache.ac_argc,
+ exec_cache.ac_argv,
+ exec_cache.ac_envp)));
+}
+#endif /* elxsi */
+
+
+#ifdef sparc
+asm (".global __start");
+asm (".text");
+asm ("__start:");
+asm (" mov 0, %fp");
+asm (" ld [%sp + 64], %o0");
+asm (" add %sp, 68, %o1");
+asm (" sll %o0, 2, %o2");
+asm (" add %o2, 4, %o2");
+asm (" add %o1, %o2, %o2");
+asm (" sethi %hi(_environ), %o3");
+asm (" st %o2, [%o3+%lo(_environ)]");
+asm (" andn %sp, 7, %sp");
+asm (" call _main");
+asm (" sub %sp, 24, %sp");
+asm (" call __exit");
+asm (" nop");
+
+#endif /* sparc */
+
+#if __FreeBSD__ == 2
+char *__progname;
+#endif
+#ifdef __bsdi__
+#include <sys/param.h> /* for version number */
+#if defined(_BSDI_VERSION) && (_BSDI_VERSION >= 199501)
+char *__progname;
+#endif
+#endif /* __bsdi__ */
diff --git a/edline.c b/edline.c
new file mode 100644
index 0000000..ab15578
--- /dev/null
+++ b/edline.c
@@ -0,0 +1,94 @@
+/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "readline.c" Scheme interface to readline library
+ Author: Radey Shouman */
+
+#include "scm.h"
+
+char *readline P((const char *prompt));
+void add_history P((char *p));
+
+ /* Reads on stdin/stdout only */
+static char s_readline[] = "read-edited-line";
+SCM lreadline(prompt)
+ SCM prompt;
+{
+ SCM res;
+ char *s;
+ ASSERT(NIMP(prompt) && STRINGP(prompt), prompt, ARG1, s_readline);
+ s = readline(CHARS(prompt));
+ if (NULL == s) return EOF_VAL;
+ NEWCELL(res);
+ DEFER_INTS;
+ SETCHARS(res,s);
+ SETLENGTH(res,(sizet)strlen(s),tc7_string);
+ ALLOW_INTS;
+ return res;
+}
+static char s_add_history[] = "add-history";
+SCM ladd_history(line)
+ SCM line;
+{
+ ASSERT(NIMP(line) && STRINGP(line), line, ARG1, s_add_history);
+ add_history(CHARS(line));
+ return UNSPECIFIED;
+}
+static char s_def_inport[] = "default-input-port";
+SCM def_inport()
+{
+ return def_inp;
+}
+static char s_def_outport[] = "default-output-port";
+SCM def_outport()
+{
+ return def_outp;
+}
+static char s_Iedline[] = "Iedline.scm";
+void init_edline()
+{
+ make_subr(s_def_inport, tc7_subr_0, def_inport);
+ make_subr(s_def_outport, tc7_subr_0, def_outport);
+ make_subr(s_readline, tc7_subr_1, lreadline);
+ make_subr(s_add_history, tc7_subr_1, ladd_history);
+ if (scm_ldprog(s_Iedline))
+ wta(*loc_errobj, "couldn't init", s_Iedline);
+}
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 ((<var1> <init1> <step1>)
+ (<var2> <init2>)
+ ... )
+ (<test> <return>)
+ <body>)
+ ;; becomes
+ (do_mem (varn ... var2 var1)
+ (<init1> <init2> ... <initn>)
+ (<test> <return>)
+ (<body>)
+ <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+ */
+SCM m_do(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig), arg1, proc;
+ SCM vars = EOL, inits = EOL, steps = EOL;
+ SCM *initloc = &inits, *steploc = &steps;
+ int len = ilength(x);
+ ASSYNT(len >= 2, xorig, s_test, s_do);
+ proc = CAR(x);
+ ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do);
+ while NIMP(proc) {
+ arg1 = CAR(proc);
+ len = ilength(arg1);
+ ASSYNT(2==len || 3==len, xorig, s_bindings, s_do);
+ ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_do);
+ /* vars reversed here, inits and steps reversed at evaluation */
+ vars = cons(CAR(arg1), vars); /* variable */
+ arg1 = CDR(arg1);
+ *initloc = cons(CAR(arg1), EOL); /* init */
+ initloc = &CDR(*initloc);
+ arg1 = CDR(arg1);
+ *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */
+ steploc = &CDR(*steploc);
+ proc = CDR(proc);
+ }
+ x = CDR(x);
+ ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
+ x = cons2(CAR(x), CDR(x), steps);
+ x = cons2(vars, inits, x);
+ bodycheck(xorig, &CAR(CDR(CDR(x))), s_do);
+ return cons(IM_DO, x);
+}
+
+/* evalcar is small version of inline EVALCAR when we don't care about speed */
+static SCM evalcar(x, env)
+ SCM x, env;
+{
+ return EVALCAR(x, env);
+}
+
+static SCM iqq(form, env, depth)
+ SCM form, env;
+ int depth;
+{
+ SCM tmp;
+ int edepth = depth;
+ if IMP(form) return form;
+ if VECTORP(form) {
+ long i = LENGTH(form);
+ SCM *data = VELTS(form);
+ tmp = EOL;
+ for(;--i >= 0;) tmp = cons(data[i], tmp);
+ return vector(iqq(tmp, env, depth));
+ }
+ if NCONSP(form) return form;
+ tmp = CAR(form);
+ if (i_quasiquote==tmp) {
+ depth++;
+ goto label;
+ }
+ if (i_unquote==tmp) {
+ --depth;
+ label:
+ form = CDR(form);
+ ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
+ form, ARG1, s_quasiquote);
+ if (0==depth) return evalcar(form, env);
+ return cons2(tmp, iqq(CAR(form), env, depth), EOL);
+ }
+ if (NIMP(tmp) && (i_uq_splicing==CAR(tmp))) {
+ tmp = CDR(tmp);
+ if (0==--edepth)
+ return append(cons2(evalcar(tmp, env), iqq(CDR(form), env, depth), EOL));
+ }
+ return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth));
+}
+
+/* Here are acros which return values rather than code. */
+
+SCM m_quasiquote(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
+ return iqq(CAR(x), env, 1);
+}
+
+SCM m_delay(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
+ xorig = CDR(xorig);
+ return makprom(closure(cons2(EOL, CAR(xorig), CDR(xorig)), env));
+}
+
+extern int verbose;
+SCM m_define(x, env)
+ SCM x, env;
+{
+ SCM proc, arg1 = x; x = CDR(x);
+ /* ASSYNT(NULLP(env), x, "bad placement", s_define);*/
+ ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define);
+ proc = CAR(x); x = CDR(x);
+ while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */
+ x = cons(cons2(i_lambda, CDR(proc), x), EOL);
+ proc = CAR(proc);
+ }
+ ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define);
+ ASSYNT(1==ilength(x), arg1, s_expression, s_define);
+ if NULLP(env) {
+ x = evalcar(x, env);
+ arg1 = sym2vcell(proc);
+#ifndef RECKLESS
+ if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc)
+ && (CDR(arg1) != x))
+ warn("redefining built-in ", CHARS(proc));
+ else
+#endif
+ if (5 <= verbose && UNDEFINED != CDR(arg1))
+ warn("redefining ", CHARS(proc));
+ CDR(arg1) = x;
+#ifdef SICP
+ return cons2(i_quote, CAR(arg1), EOL);
+#else
+ return UNSPECIFIED;
+#endif
+ }
+ return cons2(IM_DEFINE, proc, x);
+}
+/* end of acros */
+
+SCM m_letrec(xorig, env)
+ SCM xorig, env;
+{
+ SCM cdrx = CDR(xorig); /* locally mutable version of form */
+ char *what = CHARS(CAR(xorig));
+ SCM x = cdrx, proc, arg1; /* structure traversers */
+ SCM vars = EOL, inits = EOL, *initloc = &inits;
+
+ ASRTSYNTAX(ilength(x) >= 2, s_body);
+ proc = CAR(x);
+ if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */
+ ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
+ do {
+ /* vars list reversed here, inits reversed at evaluation */
+ arg1 = CAR(proc);
+ ASRTSYNTAX(2==ilength(arg1), s_bindings);
+ ASRTSYNTAX(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), s_variable);
+ vars = cons(CAR(arg1), vars);
+ *initloc = cons(CAR(CDR(arg1)), EOL);
+ initloc = &CDR(*initloc);
+ } while NIMP(proc = CDR(proc));
+ cdrx = cons2(vars, inits, CDR(x));
+ bodycheck(xorig, &CDR(CDR(cdrx)), what);
+ return cons(IM_LETREC, cdrx);
+}
+
+SCM m_let(xorig, env)
+ SCM xorig, env;
+{
+ SCM cdrx = CDR(xorig); /* locally mutable version of form */
+ SCM x = cdrx, proc, arg1, name; /* structure traversers */
+ SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits;
+
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+ proc = CAR(x);
+ if (NULLP(proc)
+ || (NIMP(proc) && CONSP(proc)
+ && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
+ return m_letstar(xorig, env); /* null or single binding, let* is faster */
+ ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
+ if CONSP(proc) /* plain let, proc is <bindings> */
+ return cons(IM_LET, CDR(m_letrec(xorig, env)));
+ if (!SYMBOLP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
+ name = proc; /* named let, build equiv letrec */
+ x = CDR(x);
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+ proc = CAR(x); /* bindings list */
+ ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let);
+ while NIMP(proc) { /* vars and inits both in order */
+ arg1 = CAR(proc);
+ ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
+ ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let);
+ *varloc = cons(CAR(arg1), EOL);
+ varloc = &CDR(*varloc);
+ *initloc = cons(CAR(CDR(arg1)), EOL);
+ initloc = &CDR(*initloc);
+ proc = CDR(proc);
+ }
+ return
+ m_letrec(cons2(i_let,
+ cons(cons2(name, cons2(i_lambda, vars, CDR(x)), EOL), EOL),
+ acons(name, inits, EOL)), /* body */
+ env);
+}
+
+#define s_atapply (ISYMCHARS(IM_APPLY)+1)
+
+SCM m_apply(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply);
+ return cons(IM_APPLY, CDR(xorig));
+}
+
+#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)
+
+SCM m_cont(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc);
+ return cons(IM_CONT, CDR(xorig));
+}
+
+#ifndef RECKLESS
+int badargsp(formals, args)
+ SCM formals, args;
+{
+ while NIMP(formals) {
+ if NCONSP(formals) return 0;
+ if IMP(args) return 1;
+ formals = CDR(formals);
+ args = CDR(args);
+ }
+ return NNULLP(args) ? 1 : 0;
+}
+#endif
+
+char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
+SCM eqv P((SCM x, SCM y));
+long tc16_macro; /* Type code for macros */
+#ifdef CAUTIOUS
+static char s_bottom[] = "stacktrace bottommed out";
+#endif
+
+SCM ceval(x, env)
+ SCM x, env;
+{
+ union {SCM *lloc; SCM arg1;} t;
+ SCM proc, arg2;
+ CHECK_STACK;
+ loop: POLL;
+ switch TYP7(x) {
+ case tcs_symbols:
+ /* only happens when called at top level */
+ x = cons(x, UNDEFINED);
+ goto retval;
+ case (127 & IM_AND):
+ x = CDR(x);
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1)))
+ if FALSEP(EVALCAR(x, env)) return BOOL_F;
+ else x = t.arg1;
+ goto carloop;
+ cdrtcdrxbegin:
+#ifdef CAUTIOUS
+ ASSERT(NIMP(stacktrace), EOL, s_bottom, s_eval);
+ stacktrace = CDR(stacktrace);
+#endif
+ cdrxbegin:
+ case (127 & IM_BEGIN):
+ x = CDR(x);
+ begin:
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ SIDEVAL(CAR(x), env);
+ x = t.arg1;
+ }
+ carloop: /* eval car of last form in list */
+ if NCELLP(CAR(x)) {
+ x = CAR(x);
+ return IMP(x)?EVALIMP(x, env):I_VAL(x);
+ }
+ if SYMBOLP(CAR(x)) {
+ retval:
+ return *lookupcar(x, env);
+ }
+ x = CAR(x);
+ goto loop; /* tail recurse */
+
+ case (127 & IM_CASE):
+ x = CDR(x);
+ t.arg1 = EVALCAR(x, env);
+ while(NIMP(x = CDR(x))) {
+ proc = CAR(x);
+ if (i_else==CAR(proc)) {
+ x = CDR(proc);
+ goto begin;
+ }
+ proc = CAR(proc);
+ while NIMP(proc) {
+ if (CAR(proc)==t.arg1
+#ifdef FLOATS
+ || NFALSEP(eqv(CAR(proc), t.arg1))
+#endif
+ ) {
+ x = CDR(CAR(x));
+ goto begin;
+ }
+ proc = CDR(proc);
+ }
+ }
+ return UNSPECIFIED;
+ case (127 & IM_COND):
+ while(NIMP(x = CDR(x))) {
+ proc = CAR(x);
+ t.arg1 = EVALCAR(proc, env);
+ if NFALSEP(t.arg1) {
+ x = CDR(proc);
+ if NULLP(x) return t.arg1;
+ if (i_arrow != CAR(x)) goto begin;
+ proc = CDR(x);
+ proc = EVALCAR(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+#ifdef CAUTIOUS
+ if CLOSUREP(proc) goto checkargs1;
+#endif
+ goto evap1;
+ }
+ }
+ return UNSPECIFIED;
+ case (127 & IM_DO):
+ x = CDR(x);
+ proc = CAR(CDR(x)); /* inits */
+ t.arg1 = EOL; /* values */
+ while NIMP(proc) {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ proc = CDR(proc);
+ }
+ env = EXTEND_ENV(CAR(x), t.arg1, env);
+ x = CDR(CDR(x));
+ while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) {
+ for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
+ t.arg1 = CAR(proc); /* body */
+ SIDEVAL(t.arg1, env);
+ }
+ for(t.arg1 = EOL, proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc))
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1); /* steps */
+ env = EXTEND_ENV(CAR(CAR(env)), t.arg1, CDR(env));
+ }
+ x = CDR(proc);
+ if NULLP(x) return UNSPECIFIED;
+ goto begin;
+ case (127 & IM_IF):
+ x = CDR(x);
+ if NFALSEP(EVALCAR(x, env)) x = CDR(x);
+ else if IMP(x = CDR(CDR(x))) return UNSPECIFIED;
+ goto carloop;
+ case (127 & IM_LET):
+ x = CDR(x);
+ proc = CAR(CDR(x));
+ t.arg1 = EOL;
+ do {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ } while NIMP(proc = CDR(proc));
+ env = EXTEND_ENV(CAR(x), t.arg1, env);
+ x = CDR(x);
+ goto cdrxbegin;
+ case (127 & IM_LETREC):
+ x = CDR(x);
+ env = EXTEND_ENV(CAR(x), undefineds, env);
+ x = CDR(x);
+ proc = CAR(x);
+ t.arg1 = EOL;
+ do {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ } while NIMP(proc = CDR(proc));
+ CDR(CAR(env)) = t.arg1;
+ goto cdrxbegin;
+ case (127 & IM_LETSTAR):
+ x = CDR(x);
+ proc = CAR(x);
+ if IMP(proc) {
+ env = EXTEND_ENV(EOL, EOL, env);
+ goto cdrxbegin;
+ }
+ do {
+ t.arg1 = CAR(proc);
+ proc = CDR(proc);
+ env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env);
+ } while NIMP(proc = CDR(proc));
+ goto cdrxbegin;
+ case (127 & IM_OR):
+ x = CDR(x);
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ x = EVALCAR(x, env);
+ if NFALSEP(x) return x;
+ x = t.arg1;
+ }
+ goto carloop;
+ case (127 & IM_LAMBDA):
+ return closure(CDR(x), env);
+ case (127 & IM_QUOTE):
+ return CAR(CDR(x));
+ case (127 & IM_SET):
+ x = CDR(x);
+ proc = CAR(x);
+ switch (7 & (int)proc) {
+ case 0:
+ t.lloc = lookupcar(x, env);
+ break;
+ case 1:
+ t.lloc = &I_VAL(proc);
+ break;
+#ifdef MEMOIZE_LOCALS
+ case 4:
+ t.lloc = ilookup(proc, env);
+ break;
+#endif
+ }
+ x = CDR(x);
+ *t.lloc = EVALCAR(x, env);
+#ifdef SICP
+ return *t.lloc;
+#else
+ return UNSPECIFIED;
+#endif
+ case (127 & IM_DEFINE): /* only for internal defines */
+ x = CDR(x);
+ proc = CAR(x);
+ x = CDR(x);
+ x = evalcar(x, env);
+ env = CAR(env);
+ DEFER_INTS;
+ CAR(env) = cons(proc, CAR(env));
+ CDR(env) = cons(x, CDR(env));
+ ALLOW_INTS;
+ return UNSPECIFIED;
+ /* new syntactic forms go here. */
+ case (127 & MAKISYM(0)):
+ proc = CAR(x);
+ ASRTGO(ISYMP(proc), badfun);
+ switch ISYMNUM(proc) {
+ case (ISYMNUM(IM_APPLY)):
+ proc = CDR(x);
+ proc = EVALCAR(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+ if (CLOSUREP(proc)) {
+ t.arg1 = CDR(CDR(x));
+ t.arg1 = EVALCAR(t.arg1, env);
+#ifndef RECKLESS
+ if (badargsp(CAR(CODE(proc)), t.arg1)) goto wrongnumargs;
+#endif
+ env = EXTEND_ENV(CAR(CODE(proc)), t.arg1, ENV(proc));
+ x = CODE(proc);
+ goto cdrxbegin;
+ }
+ proc = i_apply;
+ goto evapply;
+ case (ISYMNUM(IM_CONT)):
+ t.arg1 = scm_make_cont();
+ if (proc = setjmp(CONT(t.arg1)->jmpbuf))
+#ifdef SHORT_INT
+ return (SCM)thrown_value;
+#else
+ return (SCM)proc;
+#endif
+ proc = CDR(x);
+ proc = evalcar(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+#ifdef CAUTIOUS
+ if CLOSUREP(proc) {
+ checkargs1:
+ stacktrace = cons(x, stacktrace);
+ /* Check that argument list of proc can match 1 arg. */
+ arg2 = CAR(CODE(proc));
+ ASRTGO(NIMP(arg2), wrongnumargs);
+ if NCONSP(arg2) goto evap1;
+ arg2 = CDR(arg2);
+ ASRTGO(NULLP(arg2) || NCONSP(arg2), wrongnumargs);
+ }
+#endif
+ goto evap1;
+ default:
+ goto badfun;
+ }
+ default:
+ proc = x;
+ badfun:
+ everr(x, env, proc, "Wrong type to apply: ", "");
+ case tc7_vector:
+ case tc7_bvect: case tc7_ivect: case tc7_uvect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ case tc7_string:
+ case tc7_smob:
+ return x;
+#ifdef MEMOIZE_LOCALS
+ case (127 & ILOC00):
+ proc = *ilookup(CAR(x), env);
+ ASRTGO(NIMP(proc), badfun);
+# ifndef RECKLESS
+# ifdef CAUTIOUS
+ goto checkargs;
+# endif
+# endif
+ break;
+#endif /* ifdef MEMOIZE_LOCALS */
+ case tcs_cons_gloc:
+ proc = I_VAL(CAR(x));
+ ASRTGO(NIMP(proc), badfun);
+#ifndef RECKLESS
+# ifdef CAUTIOUS
+ goto checkargs;
+# endif
+#endif
+ break;
+ case tcs_cons_nimcar:
+ if SYMBOLP(CAR(x)) {
+ proc = *lookupcar(x, env);
+ if IMP(proc) {unmemocar(x, env); goto badfun;}
+ if (tc16_macro==TYP16(proc)) {
+ unmemocar(x, env);
+ t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
+ switch ((int)(CAR(proc)>>16)) {
+ case 2:
+ if (ilength(t.arg1) <= 0)
+ t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
+ DEFER_INTS;
+ CAR(x) = CAR(t.arg1);
+ CDR(x) = CDR(t.arg1);
+ ALLOW_INTS;
+ goto loop;
+ case 1:
+ if NIMP(x = t.arg1) goto loop;
+ case 0:
+ return t.arg1;
+ }
+ }
+ }
+ else proc = ceval(CAR(x), env);
+ ASRTGO(NIMP(proc), badfun);
+#ifndef RECKLESS
+# ifdef CAUTIOUS
+ checkargs:
+# endif
+ /* At this point proc is the evaluated procedure from the function
+ position and x has the form which is being evaluated. */
+ if CLOSUREP(proc) {
+# ifdef CAUTIOUS
+ stacktrace = cons(x, stacktrace);
+# endif
+ arg2 = CAR(CODE(proc));
+ t.arg1 = CDR(x);
+ while NIMP(arg2) {
+ if NCONSP(arg2) {
+ goto evapply;
+ }
+ if IMP(t.arg1) goto umwrongnumargs;
+ arg2 = CDR(arg2);
+ t.arg1 = CDR(t.arg1);
+ }
+ if NNULLP(t.arg1) goto umwrongnumargs;
+ }
+#endif
+ }
+ evapply:
+ if NULLP(CDR(x)) switch TYP7(proc) { /* no arguments given */
+ case tc7_subr_0:
+ return SUBRF(proc)();
+ case tc7_subr_1o:
+ return SUBRF(proc) (UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(EOL);
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(UNDEFINED, UNDEFINED);
+#ifdef CCLO
+ case tc7_cclo:
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap1;
+#endif
+ case tcs_closures:
+ x = CODE(proc);
+ env = EXTEND_ENV(CAR(x), EOL, ENV(proc));
+ goto cdrtcdrxbegin;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ case tc7_cxr:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ umwrongnumargs:
+ unmemocar(x, env);
+ wrongnumargs:
+ everr(x, env, proc, (char *)WNA, "");
+ default:
+ goto badfun;
+ }
+ x = CDR(x);
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ t.arg1 = EVALCAR(x, env);
+ x = CDR(x);
+ if NULLP(x)
+evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ return SUBRF(proc)(t.arg1);
+ case tc7_cxr:
+#ifdef FLOATS
+ if SUBRF(proc) {
+ if INUMP(t.arg1)
+ return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0);
+ ASRTGO(NIMP(t.arg1), floerr);
+ if REALP(t.arg1)
+ return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0);
+# ifdef BIGDIG
+ if BIGP(t.arg1)
+ return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
+# endif
+ floerr:
+ wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc)));
+ }
+#endif
+ proc = (SCM)SNAME(proc);
+ {
+ char *chrs = CHARS(proc)+LENGTH(proc)-1;
+ while('c' != *--chrs) {
+ ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
+ t.arg1, ARG1, CHARS(proc));
+ t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1);
+ }
+ return t.arg1;
+ }
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons(t.arg1, EOL));
+#ifdef CCLO
+ case tc7_cclo:
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap2;
+#endif
+ case tcs_closures:
+ x = CODE(proc);
+ env = EXTEND_ENV(CAR(x), cons(t.arg1, EOL), ENV(proc));
+ goto cdrtcdrxbegin;
+ case tc7_contin:
+ scm_dynthrow(CONT(proc), t.arg1);
+ case tc7_subr_2:
+ case tc7_subr_0:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ { /* have two or more arguments */
+ arg2 = EVALCAR(x, env);
+ x = CDR(x);
+ if NULLP(x)
+#ifdef CCLO
+ evap2:
+#endif
+ switch TYP7(proc) { /* have two arguments */
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, EOL);
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, arg2);
+#ifdef CCLO
+ cclon: case tc7_cclo:
+ return apply(CCLO_SUBR(proc), proc,
+ cons2(t.arg1, arg2, cons(eval_args(x, env), EOL)));
+/* case tc7_cclo:
+ x = cons(arg2, eval_args(x, env));
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap3; */
+#endif
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1o:
+ case tc7_subr_1:
+ case tc7_subr_3:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ case tcs_closures:
+ env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1, arg2, EOL), ENV(proc));
+ x = CODE(proc);
+ goto cdrtcdrxbegin;
+ }
+ switch TYP7(proc) { /* have 3 or more arguments */
+ case tc7_subr_3:
+ ASRTGO(NULLP(CDR(x)), wrongnumargs);
+ return SUBRF(proc)(t.arg1, arg2, EVALCAR(x, env));
+ case tc7_asubr:
+/* t.arg1 = SUBRF(proc)(t.arg1, arg2);
+ while NIMP(x) {
+ t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = CDR(x);
+ }
+ return t.arg1; */
+ case tc7_rpsubr:
+ return apply(proc, t.arg1, acons(arg2, eval_args(x, env), EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, eval_args(x, env));
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, eval_args(x, env)));
+#ifdef CCLO
+ case tc7_cclo: goto cclon;
+#endif
+ case tcs_closures:
+ env = EXTEND_ENV(CAR(CODE(proc)),
+ cons2(t.arg1, arg2, eval_args(x, env)),
+ ENV(proc));
+ x = CODE(proc);
+ goto cdrtcdrxbegin;
+ case tc7_subr_2:
+ case tc7_subr_1o:
+ case tc7_subr_2o:
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
+ }
+}
+
+SCM procedurep(obj)
+ SCM obj;
+{
+ if NIMP(obj) switch TYP7(obj) {
+ case tcs_closures:
+ case tc7_contin:
+ case tcs_subrs:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+ return BOOL_T;
+ }
+ return BOOL_F;
+}
+
+static char s_proc_doc[] = "procedure-documentation";
+SCM l_proc_doc(proc)
+ SCM proc;
+{
+ SCM code;
+ ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin,
+ proc, ARG1, s_proc_doc);
+ switch TYP7(proc) {
+ case tcs_closures:
+ code = CDR(CODE(proc));
+ if IMP(CDR(code)) return BOOL_F;
+ code = CAR(code);
+ if IMP(code) return BOOL_F;
+ if STRINGP(code) return code;
+ default:
+ return BOOL_F;
+/*
+ case tcs_subrs:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+*/
+ }
+}
+
+/* This code is for apply. it is destructive on multiple args.
+ This will only screw you if you do (apply apply '( ... )) */
+SCM nconc2last(lst)
+ SCM lst;
+{
+ SCM *lloc = &lst;
+#ifdef CAUTIOUS
+ ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
+#endif
+ while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc);
+#ifdef CAUTIOUS
+ ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
+#endif
+ *lloc = CAR(*lloc);
+ return lst;
+}
+
+
+SCM apply(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ ASRTGO(NIMP(proc), badproc);
+ if NULLP(args)
+ if NULLP(arg1) arg1 = UNDEFINED;
+ else {
+ args = CDR(arg1);
+ arg1 = CAR(arg1);
+ }
+ else {
+ /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
+ args = nconc2last(args);
+ }
+#ifdef CCLO
+ tail:
+#endif
+ switch TYP7(proc) {
+ case tc7_subr_2o:
+ args = NULLP(args)?UNDEFINED:CAR(args);
+ return SUBRF(proc)(arg1, args);
+ case tc7_subr_2:
+ ASRTGO(NULLP(CDR(args)), wrongnumargs);
+ args = CAR(args);
+ return SUBRF(proc)(arg1, args);
+ case tc7_subr_0:
+ ASRTGO(UNBNDP(arg1), wrongnumargs);
+ return SUBRF(proc)();
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ ASRTGO(NULLP(args), wrongnumargs);
+ return SUBRF(proc)(arg1);
+ case tc7_cxr:
+ ASRTGO(NULLP(args), wrongnumargs);
+#ifdef FLOATS
+ if SUBRF(proc) {
+ if INUMP(arg1)
+ return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
+ ASRTGO(NIMP(arg1), floerr);
+ if REALP(arg1)
+ return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
+# ifdef BIGDIG
+ if BIGP(arg1)
+ return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
+# endif
+ floerr:
+ wta(arg1, (char *)ARG1, CHARS(SNAME(proc)));
+ }
+#endif
+ proc = (SCM)SNAME(proc);
+ {
+ char *chrs = CHARS(proc)+LENGTH(proc)-1;
+ while('c' != *--chrs) {
+ ASSERT(NIMP(arg1) && CONSP(arg1),
+ arg1, ARG1, CHARS(proc));
+ arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1);
+ }
+ return arg1;
+ }
+ case tc7_subr_3:
+ return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
+ case tc7_lsubr:
+ return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
+ case tc7_lsubr_2:
+ ASRTGO(NIMP(args) && CONSP(args), wrongnumargs);
+ return SUBRF(proc)(arg1, CAR(args), CDR(args));
+ case tc7_asubr:
+ if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED);
+ while NIMP(args) {
+ ASSERT(CONSP(args), args, ARG2, s_apply);
+ arg1 = SUBRF(proc)(arg1, CAR(args));
+ args = CDR(args);
+ }
+ return arg1;
+ case tc7_rpsubr:
+ if NULLP(args) return BOOL_T;
+ while NIMP(args) {
+ ASSERT(CONSP(args), args, ARG2, s_apply);
+ if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F;
+ arg1 = CAR(args);
+ args = CDR(args);
+ }
+ return BOOL_T;
+ case tcs_closures:
+ arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+#ifndef RECKLESS
+ if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs;
+#endif
+ args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc));
+ proc = CODE(proc);
+ while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args);
+ return arg1;
+ case tc7_contin:
+ ASRTGO(NULLP(args), wrongnumargs);
+ scm_dynthrow(CONT(proc), arg1);
+#ifdef CCLO
+ case tc7_cclo:
+ args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+ arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto tail;
+#endif
+ wrongnumargs:
+ wta(proc, (char *)WNA, s_apply);
+ default:
+ badproc:
+ wta(proc, (char *)ARG1, s_apply);
+ return arg1;
+ }
+}
+
+SCM map(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ long i;
+ SCM res = EOL, *pres = &res;
+ SCM *ve = &args; /* Keep args from being optimized away. */
+ if NULLP(arg1) return res;
+ ASSERT(NIMP(arg1), arg1, ARG2, s_map);
+ if NULLP(args) {
+ while NIMP(arg1) {
+ ASSERT(CONSP(arg1), arg1, ARG2, s_map);
+ *pres = cons(apply(proc, CAR(arg1), listofnull), EOL);
+ pres = &CDR(*pres);
+ arg1 = CDR(arg1);
+ }
+ return res;
+ }
+ args = vector(cons(arg1, args));
+ ve = VELTS(args);
+#ifndef RECKLESS
+ for(i = LENGTH(args)-1; i >= 0; i--)
+ ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map);
+#endif
+ while (1) {
+ arg1 = EOL;
+ for (i = LENGTH(args)-1;i >= 0;i--) {
+ if IMP(ve[i]) return res;
+ arg1 = cons(CAR(ve[i]), arg1);
+ ve[i] = CDR(ve[i]);
+ }
+ *pres = cons(apply(proc, arg1, EOL), EOL);
+ pres = &CDR(*pres);
+ }
+}
+SCM for_each(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ SCM *ve = &args; /* Keep args from being optimized away. */
+ long i;
+ if NULLP(arg1) return UNSPECIFIED;
+ ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
+ if NULLP(args) {
+ while NIMP(arg1) {
+ ASSERT(CONSP(arg1), arg1, ARG2, s_for_each);
+ apply(proc, CAR(arg1), listofnull);
+ arg1 = CDR(arg1);
+ }
+ return UNSPECIFIED;
+ }
+ args = vector(cons(arg1, args));
+ ve = VELTS(args);
+ while (1) {
+ arg1 = EOL;
+ for (i = LENGTH(args)-1;i >= 0;i--) {
+ if IMP(ve[i]) return UNSPECIFIED;
+ arg1 = cons(CAR(ve[i]), arg1);
+ ve[i] = CDR(ve[i]);
+ }
+ apply(proc, arg1, EOL);
+ }
+}
+
+SCM closure(code, env)
+ SCM code, env;
+{
+ register SCM z;
+ NEWCELL(z);
+ SETCODE(z, code);
+ ENV(z) = env;
+ return z;
+}
+
+long tc16_promise;
+SCM makprom(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_promise;
+ return z;
+}
+static int prinprom(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ lputs("#<promise ", port);
+ iprin1(CDR(exp), port, writing);
+ lputc('>', port);
+ return !0;
+}
+
+SCM makacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro;
+ return z;
+}
+SCM makmacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro | (1L<<16);
+ return z;
+}
+SCM makmmacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro | (2L<<16);
+ return z;
+}
+static int prinmacro(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ if (CAR(exp) & (3L<<16)) lputs("#<macro", port);
+ else lputs("#<syntax", port);
+ if (CAR(exp) & (2L<<16)) lputc('!', port);
+ lputc(' ', port);
+ iprin1(CDR(exp), port, writing);
+ lputc('>', port);
+ return !0;
+}
+
+char s_force[] = "force";
+SCM force(x)
+ SCM x;
+{
+ ASSERT((TYP16(x)==tc16_promise), x, ARG1, s_force);
+ if (!((1L<<16) & CAR(x))) {
+ SCM ans = apply(CDR(x), EOL, EOL);
+ if (!((1L<<16) & CAR(x))) {
+ DEFER_INTS;
+ CDR(x) = ans;
+ CAR(x) |= (1L<<16);
+ ALLOW_INTS;
+ }
+ }
+ return CDR(x);
+}
+
+SCM copytree(obj)
+ SCM obj;
+{
+ SCM ans, tl;
+ if IMP(obj) return obj;
+ if VECTORP(obj) {
+ sizet i = LENGTH(obj);
+ ans = make_vector(MAKINUM(i), UNSPECIFIED);
+ while(i--) VELTS(ans)[i] = copytree(VELTS(obj)[i]);
+ return ans;
+ }
+ if NCONSP(obj) return obj;
+/* return cons(copytree(CAR(obj)), copytree(CDR(obj))); */
+ ans = tl = cons(copytree(CAR(obj)), UNSPECIFIED);
+ while(NIMP(obj = CDR(obj)) && CONSP(obj))
+ tl = (CDR(tl) = cons(copytree(CAR(obj)), UNSPECIFIED));
+ CDR(tl) = obj;
+ return ans;
+}
+SCM eval(obj)
+ SCM obj;
+{
+ obj = copytree(obj);
+ return EVAL(obj, (SCM)EOL);
+}
+
+SCM definedp(x, env)
+ SCM x, env;
+{
+ SCM proc = CAR(x = CDR(x));
+ return (ISYMP(proc)
+ || (NIMP(proc) && SYMBOLP(proc)
+ && !UNBNDP(CDR(sym2vcell(proc)))))?
+ (SCM)BOOL_T : (SCM)BOOL_F;
+}
+
+static iproc subr1s[] = {
+ {"copy-tree", copytree},
+ {s_eval, eval},
+ {s_force, force},
+ {s_proc_doc, l_proc_doc},
+ {"procedure->syntax", makacro},
+ {"procedure->macro", makmacro},
+ {"procedure->memoizing-macro", makmmacro},
+ {"apply:nconc-to-last", nconc2last},
+ {0, 0}};
+
+static iproc lsubr2s[] = {
+/* {s_apply, apply}, now explicity initted */
+ {s_map, map},
+ {s_for_each, for_each},
+ {0, 0}};
+
+static smobfuns promsmob = {markcdr, free0, prinprom};
+static smobfuns macrosmob = {markcdr, free0, prinmacro};
+
+SCM make_synt(name, macroizer, fcn)
+ char *name;
+ SCM (*macroizer)();
+ SCM (*fcn)();
+{
+ SCM symcell = sysintern(name, UNDEFINED);
+ long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
+ register SCM z;
+ if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
+ tmp = 0;
+ NEWCELL(z);
+ SUBRF(z) = fcn;
+ CAR(z) = tmp + tc7_subr_2;
+ CDR(symcell) = macroizer(z);
+ return CAR(symcell);
+}
+
+void init_eval()
+{
+ tc16_promise = newsmob(&promsmob);
+ tc16_macro = newsmob(&macrosmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ i_apply = make_subr(s_apply, tc7_lsubr_2, apply);
+ i_dot = CAR(sysintern(".", UNDEFINED));
+ i_arrow = CAR(sysintern("=>", UNDEFINED));
+ i_else = CAR(sysintern("else", UNDEFINED));
+ i_unquote = CAR(sysintern("unquote", UNDEFINED));
+ i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));
+
+ /* acros */
+ i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote);
+ make_synt(s_define, makmmacro, m_define);
+ make_synt(s_delay, makacro, m_delay);
+ /* end of acros */
+
+ make_synt(s_and, makmmacro, m_and);
+ make_synt(s_begin, makmmacro, m_begin);
+ make_synt(s_case, makmmacro, m_case);
+ make_synt(s_cond, makmmacro, m_cond);
+ make_synt(s_do, makmmacro, m_do);
+ make_synt(s_if, makmmacro, m_if);
+ i_lambda = make_synt(s_lambda, makmmacro, m_lambda);
+ i_let = make_synt(s_let, makmmacro, m_let);
+ make_synt(s_letrec, makmmacro, m_letrec);
+ make_synt(s_letstar, makmmacro, m_letstar);
+ make_synt(s_or, makmmacro, m_or);
+ i_quote = make_synt(s_quote, makmmacro, m_quote);
+ make_synt(s_set, makmmacro, m_set);
+ make_synt(s_atapply, makmmacro, m_apply);
+ make_synt(s_atcall_cc, makmmacro, m_cont);
+
+ make_synt("defined?", makacro, definedp);
+}
diff --git a/example.scm b/example.scm
new file mode 100644
index 0000000..4a7b4a0
--- /dev/null
+++ b/example.scm
@@ -0,0 +1,137 @@
+;From Revised^4 Report on the Algorithmic Language Scheme
+;William Clinger and Jonathon Rees (Editors)
+
+; EXAMPLE
+
+;INTEGRATE-SYSTEM integrates the system
+; y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n
+;of differential equations with the method of Runge-Kutta.
+
+;The parameter SYSTEM-DERIVATIVE is a function that takes a system
+;state (a vector of values for the state variables y_1, ..., y_n) and
+;produces a system derivative (the values y_1', ..., y_n'). The
+;parameter INITIAL-STATE provides an initial system state, and H is an
+;initial guess for the length of the integration step.
+
+;The value returned by INTEGRATE-SYSTEM is an infinite stream of
+;system states.
+
+(define integrate-system
+ (lambda (system-derivative initial-state h)
+ (let ((next (runge-kutta-4 system-derivative h)))
+ (letrec ((states
+ (cons initial-state
+ (delay (map-streams next states)))))
+ states))))
+
+;RUNGE-KUTTA-4 takes a function, F, that produces a
+;system derivative from a system state. RUNGE-KUTTA-4
+;produces a function that takes a system state and
+;produces a new system state.
+
+(define runge-kutta-4
+ (lambda (f h)
+ (let ((*h (scale-vector h))
+ (*2 (scale-vector 2))
+ (*1/2 (scale-vector (/ 1 2)))
+ (*1/6 (scale-vector (/ 1 6))))
+ (lambda (y)
+ ;; Y is a system state
+ (let* ((k0 (*h (f y)))
+ (k1 (*h (f (add-vectors y (*1/2 k0)))))
+ (k2 (*h (f (add-vectors y (*1/2 k1)))))
+ (k3 (*h (f (add-vectors y k2)))))
+ (add-vectors y
+ (*1/6 (add-vectors k0
+ (*2 k1)
+ (*2 k2)
+ k3))))))))
+
+(define elementwise
+ (lambda (f)
+ (lambda vectors
+ (generate-vector
+ (vector-length (car vectors))
+ (lambda (i)
+ (apply f
+ (map (lambda (v) (vector-ref v i))
+ vectors)))))))
+
+(define generate-vector
+ (lambda (size proc)
+ (let ((ans (make-vector size)))
+ (letrec ((loop
+ (lambda (i)
+ (cond ((= i size) ans)
+ (else
+ (vector-set! ans i (proc i))
+ (loop (+ i 1)))))))
+ (loop 0)))))
+
+(define add-vectors (elementwise +))
+
+(define scale-vector
+ (lambda (s)
+ (elementwise (lambda (x) (* x s)))))
+
+;MAP-STREAMS is analogous to MAP: it applies its first
+;argument (a procedure) to all the elements of its second argument (a
+;stream).
+
+(define map-streams
+ (lambda (f s)
+ (cons (f (head s))
+ (delay (map-streams f (tail s))))))
+
+;Infinite streams are implemented as pairs whose car holds the first
+;element of the stream and whose cdr holds a promise to deliver the rest
+;of the stream.
+
+(define head car)
+(define tail
+ (lambda (stream) (force (cdr stream))))
+
+
+;The following illustrates the use of INTEGRATE-SYSTEM in
+;integrating the system
+;
+; dvC vC
+; C --- = -i - --
+; dt L R
+;
+; diL
+; L --- = v
+; dt C
+;
+;which models a damped oscillator.
+
+(define damped-oscillator
+ (lambda (R L C)
+ (lambda (state)
+ (let ((Vc (vector-ref state 0))
+ (Il (vector-ref state 1)))
+ (vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
+ (/ Vc L))))))
+
+(define the-states
+ (integrate-system
+ (damped-oscillator 10000 1000 .001)
+ '#(1 0)
+ .01))
+
+(do ((i 10 (- i 1))
+ (s the-states (tail s)))
+ ((zero? i) (newline))
+ (newline)
+ (write (head s)))
+
+; #(1 0)
+; #(0.99895054 9.994835e-6)
+; #(0.99780226 1.9978681e-5)
+; #(0.9965554 2.9950552e-5)
+; #(0.9952102 3.990946e-5)
+; #(0.99376684 4.985443e-5)
+; #(0.99222565 5.9784474e-5)
+; #(0.9905868 6.969862e-5)
+; #(0.9888506 7.9595884e-5)
+; #(0.9870173 8.94753e-5)
diff --git a/findexec.c b/findexec.c
new file mode 100644
index 0000000..bbeac76
--- /dev/null
+++ b/findexec.c
@@ -0,0 +1,145 @@
+/* This file was part of DLD, a dynamic link/unlink editor for C.
+
+ Copyright (C) 1990 by W. Wilson Ho.
+
+ The author can be reached electronically by how@cs.ucdavis.edu or
+ through physical mail at:
+
+ W. Wilson Ho
+ Division of Computer Science
+ University of California at Davis
+ Davis, CA 95616
+
+Fri Sep 14 22:16:14 1990 Edgar Roeder (edgar at megamaster)
+
+ * added a separate DLDPATH environment variable in
+ dld_find_executable so that users may specify a special path
+ for object modules.
+
+Thu Feb 3 01:46:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * find_exec.c (dld_find_executable): added stat check for
+ linux so that it doesn't think directories with the same name
+ as the program are executable.
+
+Wed Feb 21 23:06:35 1996 Aubrey Jaffer <jaffer@jacal.bertronics>
+
+ * find_exec.c: extracted for general use. Generalized to
+ MS-DOS. */
+
+/* This program is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by the
+ Free Software Foundation; either version 1, or (at your option) any
+ later version. */
+
+/* Given a filename, dld_find_executable searches the directories
+ listed in the environment variable PATH for a file with that
+ filename. A new copy of the complete path name of that file is
+ returned. This new string may be disposed by free() later on. */
+
+#include <sys/file.h>
+#include <sys/param.h>
+#ifdef linux
+# include <stdlib.h>
+# include <sys/stat.h>
+# include <unistd.h> /* for X_OK define */
+#endif
+#ifdef __svr4__
+# include <string.h>
+# include <stdlib.h>
+# include <sys/stat.h>
+# include <unistd.h> /* for X_OK define */
+#else
+# ifdef __sgi__
+# include <string.h>
+# include <stdlib.h>
+# include <sys/stat.h>
+# include <unistd.h> /* for X_OK define */
+# else
+# include <strings.h>
+# endif
+#endif
+#ifndef __STDC__
+# define const /**/
+#endif
+
+#ifndef DEFAULT_PATH
+# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts"
+#endif
+
+static char *copy_of(s)
+ register const char *s;
+{
+ register char *p = (char *) malloc(strlen(s)+1);
+ if (!p) return 0;
+ *p = 0;
+ strcpy(p, s);
+ return p;
+}
+
+/* ABSOLUTE_FILENAME_P(fname): True if fname is an absolute filename */
+#ifdef atarist
+# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') || \
+ (fname[0] && (fname[1] == ':')))
+#else
+# define ABSOLUTE_FILENAME_P(fname) (fname[0] == '/')
+#endif /* atarist */
+
+char *dld_find_executable(name)
+ const char *name;
+{
+ char *search;
+ register char *p;
+ char tbuf[MAXPATHLEN];
+
+ if (ABSOLUTE_FILENAME_P(name))
+ return copy_of(name);
+
+ if ((name[0] == '.') && (name[1] == '/')) {
+ getcwd(tbuf, MAXPATHLEN);
+ strcat(tbuf, name + 1);
+ return copy_of(tbuf);
+ }
+
+ if (((search = (char *) getenv("DLDPATH")) == 0) &&
+ ((search = (char *) getenv("PATH")) == 0))
+ search = DEFAULT_PATH;
+
+ p = search;
+
+ while (*p) {
+ register char *next = tbuf;
+
+ if (p[0]=='~' && p[1]=='/' && getenv("HOME")) {
+ strcpy(tbuf, (char *)getenv("HOME"));
+ next = tbuf + strlen(tbuf);
+ p++;
+ }
+
+ /* Copy directory name into [tbuf] */
+ while (*p && *p != ':') *next++ = *p++;
+ *next = 0;
+ if (*p) p++;
+
+ if (tbuf[0] == '.' && tbuf[1] == 0)
+ getcwd(tbuf, MAXPATHLEN); /* was getwd(tbuf); */
+ else if (tbuf[0]=='~' && tbuf[1]==0 && getenv("HOME"))
+ strcpy(tbuf, (char *)getenv("HOME"));
+
+ strcat(tbuf, "/");
+ strcat(tbuf, name);
+
+ if (access(tbuf, X_OK) == 0) {
+#ifndef hpux
+# ifndef ultrix
+ struct stat stat_temp;
+ if (stat(tbuf,&stat_temp)) continue;
+ if (S_IFREG != (S_IFMT & stat_temp.st_mode)) continue;
+# endif/* ultrix */
+#endif /* hpux */
+ return copy_of(tbuf);
+ }
+ }
+
+ return 0;
+}
diff --git a/gmalloc.c b/gmalloc.c
new file mode 100644
index 0000000..59874ee
--- /dev/null
+++ b/gmalloc.c
@@ -0,0 +1,1638 @@
+/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */
+
+#define _MALLOC_INTERNAL
+
+/* The malloc headers and source files from the C library follow here. */
+
+/* Declarations for `malloc' and friends.
+ Copyright 1990, 91, 92, 93, 95, 96 Free Software Foundation, Inc.
+ Written May 1989 by Mike Haertel.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#ifndef _MALLOC_H
+
+#define _MALLOC_H 1
+
+#ifdef _MALLOC_INTERNAL
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#if defined (__cplusplus) || (defined (__STDC__) && __STDC__)
+#undef __P
+#define __P(args) args
+#undef __ptr_t
+#define __ptr_t void *
+#else /* Not C++ or ANSI C. */
+#undef __P
+#define __P(args) ()
+#undef const
+#define const
+#undef __ptr_t
+#define __ptr_t char *
+#endif /* C++ or ANSI C. */
+
+#if defined(_LIBC) || defined(STDC_HEADERS) || defined(USG)
+#include <string.h>
+#else
+#ifndef memset
+#define memset(s, zero, n) bzero ((s), (n))
+#endif
+#ifndef memcpy
+#define memcpy(d, s, n) bcopy ((s), (d), (n))
+#endif
+#endif
+
+#if defined (__GNU_LIBRARY__) || (defined (__STDC__) && __STDC__)
+#include <limits.h>
+#else
+#ifndef CHAR_BIT
+#define CHAR_BIT 8
+#endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#endif /* _MALLOC_INTERNAL. */
+
+
+#ifdef __cplusplus
+extern "C"
+{
+#endif
+
+#if defined (__STDC__) && __STDC__
+#include <stddef.h>
+#define __malloc_size_t size_t
+#define __malloc_ptrdiff_t ptrdiff_t
+#else
+#define __malloc_size_t unsigned int
+#define __malloc_ptrdiff_t int
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+
+/* Allocate SIZE bytes of memory. */
+extern __ptr_t malloc __P ((__malloc_size_t __size));
+/* Re-allocate the previously allocated block
+ in __ptr_t, making the new block SIZE bytes long. */
+extern __ptr_t realloc __P ((__ptr_t __ptr, __malloc_size_t __size));
+/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */
+extern __ptr_t calloc __P ((__malloc_size_t __nmemb, __malloc_size_t __size));
+/* Free a block allocated by `malloc', `realloc' or `calloc'. */
+extern void free __P ((__ptr_t __ptr));
+
+/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */
+#if ! (defined (_MALLOC_INTERNAL) && __DJGPP__ - 0 == 1) /* Avoid conflict. */
+extern __ptr_t memalign __P ((__malloc_size_t __alignment,
+ __malloc_size_t __size));
+#endif
+
+/* Allocate SIZE bytes on a page boundary. */
+#if ! (defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC))
+extern __ptr_t valloc __P ((__malloc_size_t __size));
+#endif
+
+
+#ifdef _MALLOC_INTERNAL
+
+/* The allocator divides the heap into blocks of fixed size; large
+ requests receive one or more whole blocks, and small requests
+ receive a fragment of a block. Fragment sizes are powers of two,
+ and all fragments of a block are the same size. When all the
+ fragments in a block have been freed, the block itself is freed. */
+#define INT_BIT (CHAR_BIT * sizeof(int))
+#define BLOCKLOG (INT_BIT > 16 ? 12 : 9)
+#define BLOCKSIZE (1 << BLOCKLOG)
+#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE)
+
+/* Determine the amount of memory spanned by the initial heap table
+ (not an absolute limit). */
+#define HEAP (INT_BIT > 16 ? 4194304 : 65536)
+
+/* Number of contiguous free blocks allowed to build up at the end of
+ memory before they will be returned to the system. */
+#define FINAL_FREE_BLOCKS 8
+
+/* Data structure giving per-block information. */
+typedef union
+ {
+ /* Heap information for a busy block. */
+ struct
+ {
+ /* Zero for a large (multiblock) object, or positive giving the
+ logarithm to the base two of the fragment size. */
+ int type;
+ union
+ {
+ struct
+ {
+ __malloc_size_t nfree; /* Free frags in a fragmented block. */
+ __malloc_size_t first; /* First free fragment of the block. */
+ } frag;
+ /* For a large object, in its first block, this has the number
+ of blocks in the object. In the other blocks, this has a
+ negative number which says how far back the first block is. */
+ __malloc_ptrdiff_t size;
+ } info;
+ } busy;
+ /* Heap information for a free block
+ (that may be the first of a free cluster). */
+ struct
+ {
+ __malloc_size_t size; /* Size (in blocks) of a free cluster. */
+ __malloc_size_t next; /* Index of next free cluster. */
+ __malloc_size_t prev; /* Index of previous free cluster. */
+ } free;
+ } malloc_info;
+
+/* Pointer to first block of the heap. */
+extern char *_heapbase;
+
+/* Table indexed by block number giving per-block information. */
+extern malloc_info *_heapinfo;
+
+/* Address to block number and vice versa. */
+#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1)
+#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase))
+
+/* Current search index for the heap table. */
+extern __malloc_size_t _heapindex;
+
+/* Limit of valid info table indices. */
+extern __malloc_size_t _heaplimit;
+
+/* Doubly linked lists of free fragments. */
+struct list
+ {
+ struct list *next;
+ struct list *prev;
+ };
+
+/* Free list headers for each fragment size. */
+extern struct list _fraghead[];
+
+/* List of blocks allocated with `memalign' (or `valloc'). */
+struct alignlist
+ {
+ struct alignlist *next;
+ __ptr_t aligned; /* The address that memaligned returned. */
+ __ptr_t exact; /* The address that malloc returned. */
+ };
+extern struct alignlist *_aligned_blocks;
+
+/* Instrumentation. */
+extern __malloc_size_t _chunks_used;
+extern __malloc_size_t _bytes_used;
+extern __malloc_size_t _chunks_free;
+extern __malloc_size_t _bytes_free;
+
+/* Internal versions of `malloc', `realloc', and `free'
+ used when these functions need to call each other.
+ They are the same but don't call the hooks. */
+extern __ptr_t _malloc_internal __P ((__malloc_size_t __size));
+extern __ptr_t _realloc_internal __P ((__ptr_t __ptr, __malloc_size_t __size));
+extern void _free_internal __P ((__ptr_t __ptr));
+
+#endif /* _MALLOC_INTERNAL. */
+
+/* Given an address in the middle of a malloc'd object,
+ return the address of the beginning of the object. */
+extern __ptr_t malloc_find_object_address __P ((__ptr_t __ptr));
+
+/* Underlying allocation function; successive calls should
+ return contiguous pieces of memory. */
+extern __ptr_t (*__morecore) __P ((__malloc_ptrdiff_t __size));
+
+/* Default value of `__morecore'. */
+extern __ptr_t __default_morecore __P ((__malloc_ptrdiff_t __size));
+
+/* If not NULL, this function is called after each time
+ `__morecore' is called to increase the data size. */
+extern void (*__after_morecore_hook) __P ((void));
+
+/* Number of extra blocks to get each time we ask for more core.
+ This reduces the frequency of calling `(*__morecore)'. */
+extern __malloc_size_t __malloc_extra_blocks;
+
+/* Nonzero if `malloc' has been called and done its initialization. */
+extern int __malloc_initialized;
+/* Function called to initialize malloc data structures. */
+extern int __malloc_initialize __P ((void));
+
+/* Hooks for debugging versions. */
+extern void (*__malloc_initialize_hook) __P ((void));
+extern void (*__free_hook) __P ((__ptr_t __ptr));
+extern __ptr_t (*__malloc_hook) __P ((__malloc_size_t __size));
+extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size));
+extern __ptr_t (*__memalign_hook) __P ((__malloc_size_t __size,
+ __malloc_size_t __alignment));
+
+/* Return values for `mprobe': these are the kinds of inconsistencies that
+ `mcheck' enables detection of. */
+enum mcheck_status
+ {
+ MCHECK_DISABLED = -1, /* Consistency checking is not turned on. */
+ MCHECK_OK, /* Block is fine. */
+ MCHECK_FREE, /* Block freed twice. */
+ MCHECK_HEAD, /* Memory before the block was clobbered. */
+ MCHECK_TAIL /* Memory after the block was clobbered. */
+ };
+
+/* Activate a standard collection of debugging hooks. This must be called
+ before `malloc' is ever called. ABORTFUNC is called with an error code
+ (see enum above) when an inconsistency is detected. If ABORTFUNC is
+ null, the standard function prints on stderr and then calls `abort'. */
+extern int mcheck __P ((void (*__abortfunc) __P ((enum mcheck_status))));
+
+/* Check for aberrations in a particular malloc'd block. You must have
+ called `mcheck' already. These are the same checks that `mcheck' does
+ when you free or reallocate a block. */
+extern enum mcheck_status mprobe __P ((__ptr_t __ptr));
+
+/* Activate a standard collection of tracing hooks. */
+extern void mtrace __P ((void));
+extern void muntrace __P ((void));
+
+/* Statistics available to the user. */
+struct mstats
+ {
+ __malloc_size_t bytes_total; /* Total size of the heap. */
+ __malloc_size_t chunks_used; /* Chunks allocated by the user. */
+ __malloc_size_t bytes_used; /* Byte total of user-allocated chunks. */
+ __malloc_size_t chunks_free; /* Chunks in the free list. */
+ __malloc_size_t bytes_free; /* Byte total of chunks in the free list. */
+ };
+
+/* Pick up the current statistics. */
+extern struct mstats mstats __P ((void));
+
+/* Call WARNFUN with a warning message when memory usage is high. */
+extern void memory_warnings __P ((__ptr_t __start,
+ void (*__warnfun) __P ((const char *))));
+
+
+/* Relocating allocator. */
+
+/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */
+extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size));
+
+/* Free the storage allocated in HANDLEPTR. */
+extern void r_alloc_free __P ((__ptr_t *__handleptr));
+
+/* Adjust the block at HANDLEPTR to be SIZE bytes long. */
+extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, __malloc_size_t __size));
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* malloc.h */
+/* Memory allocator `malloc'.
+ Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ Written May 1989 by Mike Haertel.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+#include <errno.h>
+
+/* How to really get more memory. */
+__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore;
+
+/* Debugging hook for `malloc'. */
+__ptr_t (*__malloc_hook) __P ((__malloc_size_t __size));
+
+/* Pointer to the base of the first block. */
+char *_heapbase;
+
+/* Block information table. Allocated with align/__free (not malloc/free). */
+malloc_info *_heapinfo;
+
+/* Number of info entries. */
+static __malloc_size_t heapsize;
+
+/* Search index in the info table. */
+__malloc_size_t _heapindex;
+
+/* Limit of valid info table indices. */
+__malloc_size_t _heaplimit;
+
+/* Free lists for each fragment size. */
+struct list _fraghead[BLOCKLOG];
+
+/* Instrumentation. */
+__malloc_size_t _chunks_used;
+__malloc_size_t _bytes_used;
+__malloc_size_t _chunks_free;
+__malloc_size_t _bytes_free;
+
+/* Are you experienced? */
+int __malloc_initialized;
+
+__malloc_size_t __malloc_extra_blocks;
+
+void (*__malloc_initialize_hook) __P ((void));
+void (*__after_morecore_hook) __P ((void));
+
+
+/* Aligned allocation. */
+static __ptr_t align __P ((__malloc_size_t));
+static __ptr_t
+align (size)
+ __malloc_size_t size;
+{
+ __ptr_t result;
+ unsigned long int adj;
+
+ result = (*__morecore) (size);
+ adj = (unsigned long int) ((unsigned long int) ((char *) result -
+ (char *) NULL)) % BLOCKSIZE;
+ if (adj != 0)
+ {
+ __ptr_t new;
+ adj = BLOCKSIZE - adj;
+ new = (*__morecore) (adj);
+ result = (char *) result + adj;
+ }
+
+ if (__after_morecore_hook)
+ (*__after_morecore_hook) ();
+
+ return result;
+}
+
+/* Get SIZE bytes, if we can get them starting at END.
+ Return the address of the space we got.
+ If we cannot get space at END, fail and return 0. */
+static __ptr_t get_contiguous_space __P ((__malloc_ptrdiff_t, __ptr_t));
+static __ptr_t
+get_contiguous_space (size, position)
+ __malloc_ptrdiff_t size;
+ __ptr_t position;
+{
+ __ptr_t before;
+ __ptr_t after;
+
+ before = (*__morecore) (0);
+ /* If we can tell in advance that the break is at the wrong place,
+ fail now. */
+ if (before != position)
+ return 0;
+
+ /* Allocate SIZE bytes and get the address of them. */
+ after = (*__morecore) (size);
+ if (!after)
+ return 0;
+
+ /* It was not contiguous--reject it. */
+ if (after != position)
+ {
+ (*__morecore) (- size);
+ return 0;
+ }
+
+ return after;
+}
+
+
+/* This is called when `_heapinfo' and `heapsize' have just
+ been set to describe a new info table. Set up the table
+ to describe itself and account for it in the statistics. */
+static void register_heapinfo __P ((void));
+#ifdef __GNUC__
+__inline__
+#endif
+static void
+register_heapinfo ()
+{
+ __malloc_size_t block, blocks;
+
+ block = BLOCK (_heapinfo);
+ blocks = BLOCKIFY (heapsize * sizeof (malloc_info));
+
+ /* Account for the _heapinfo block itself in the statistics. */
+ _bytes_used += blocks * BLOCKSIZE;
+ ++_chunks_used;
+
+ /* Describe the heapinfo block itself in the heapinfo. */
+ _heapinfo[block].busy.type = 0;
+ _heapinfo[block].busy.info.size = blocks;
+ /* Leave back-pointers for malloc_find_address. */
+ while (--blocks > 0)
+ _heapinfo[block + blocks].busy.info.size = -blocks;
+}
+
+/* Set everything up and remember that we have. */
+int
+__malloc_initialize ()
+{
+ if (__malloc_initialized)
+ return 0;
+
+ if (__malloc_initialize_hook)
+ (*__malloc_initialize_hook) ();
+
+ heapsize = HEAP / BLOCKSIZE;
+ _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info));
+ if (_heapinfo == NULL)
+ return 0;
+ memset (_heapinfo, 0, heapsize * sizeof (malloc_info));
+ _heapinfo[0].free.size = 0;
+ _heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
+ _heapindex = 0;
+ _heapbase = (char *) _heapinfo;
+ _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info));
+
+ register_heapinfo ();
+
+ __malloc_initialized = 1;
+ return 1;
+}
+
+static int morecore_recursing;
+
+/* Get neatly aligned memory, initializing or
+ growing the heap info table as necessary. */
+static __ptr_t morecore __P ((__malloc_size_t));
+static __ptr_t
+morecore (size)
+ __malloc_size_t size;
+{
+ __ptr_t result;
+ malloc_info *newinfo, *oldinfo;
+ __malloc_size_t newsize;
+
+ if (morecore_recursing)
+ /* Avoid recursion. The caller will know how to handle a null return. */
+ return NULL;
+
+ result = align (size);
+ if (result == NULL)
+ return NULL;
+
+ /* Check if we need to grow the info table. */
+ if ((__malloc_size_t) BLOCK ((char *) result + size) > heapsize)
+ {
+ /* Calculate the new _heapinfo table size. We do not account for the
+ added blocks in the table itself, as we hope to place them in
+ existing free space, which is already covered by part of the
+ existing table. */
+ newsize = heapsize;
+ do
+ newsize *= 2;
+ while ((__malloc_size_t) BLOCK ((char *) result + size) > newsize);
+
+ /* We must not reuse existing core for the new info table when called
+ from realloc in the case of growing a large block, because the
+ block being grown is momentarily marked as free. In this case
+ _heaplimit is zero so we know not to reuse space for internal
+ allocation. */
+ if (_heaplimit != 0)
+ {
+ /* First try to allocate the new info table in core we already
+ have, in the usual way using realloc. If realloc cannot
+ extend it in place or relocate it to existing sufficient core,
+ we will get called again, and the code above will notice the
+ `morecore_recursing' flag and return null. */
+ int save = errno; /* Don't want to clobber errno with ENOMEM. */
+ morecore_recursing = 1;
+ newinfo = (malloc_info *) _realloc_internal
+ (_heapinfo, newsize * sizeof (malloc_info));
+ morecore_recursing = 0;
+ if (newinfo == NULL)
+ errno = save;
+ else
+ {
+ /* We found some space in core, and realloc has put the old
+ table's blocks on the free list. Now zero the new part
+ of the table and install the new table location. */
+ memset (&newinfo[heapsize], 0,
+ (newsize - heapsize) * sizeof (malloc_info));
+ _heapinfo = newinfo;
+ heapsize = newsize;
+ goto got_heap;
+ }
+ }
+
+ /* Allocate new space for the malloc info table. */
+ while (1)
+ {
+ newinfo = (malloc_info *) align (newsize * sizeof (malloc_info));
+
+ /* Did it fail? */
+ if (newinfo == NULL)
+ {
+ (*__morecore) (-size);
+ return NULL;
+ }
+
+ /* Is it big enough to record status for its own space?
+ If so, we win. */
+ if ((__malloc_size_t) BLOCK ((char *) newinfo
+ + newsize * sizeof (malloc_info))
+ < newsize)
+ break;
+
+ /* Must try again. First give back most of what we just got. */
+ (*__morecore) (- newsize * sizeof (malloc_info));
+ newsize *= 2;
+ }
+
+ /* Copy the old table to the beginning of the new,
+ and zero the rest of the new table. */
+ memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info));
+ memset (&newinfo[heapsize], 0,
+ (newsize - heapsize) * sizeof (malloc_info));
+ oldinfo = _heapinfo;
+ _heapinfo = newinfo;
+ heapsize = newsize;
+
+ register_heapinfo ();
+
+ /* Reset _heaplimit so _free_internal never decides
+ it can relocate or resize the info table. */
+ _heaplimit = 0;
+ _free_internal (oldinfo);
+
+ /* The new heap limit includes the new table just allocated. */
+ _heaplimit = BLOCK ((char *) newinfo + heapsize * sizeof (malloc_info));
+ return result;
+ }
+
+ got_heap:
+ _heaplimit = BLOCK ((char *) result + size);
+ return result;
+}
+
+/* Allocate memory from the heap. */
+__ptr_t
+_malloc_internal (size)
+ __malloc_size_t size;
+{
+ __ptr_t result;
+ __malloc_size_t block, blocks, lastblocks, start;
+ register __malloc_size_t i;
+ struct list *next;
+
+ /* ANSI C allows `malloc (0)' to either return NULL, or to return a
+ valid address you can realloc and free (though not dereference).
+
+ It turns out that some extant code (sunrpc, at least Ultrix's version)
+ expects `malloc (0)' to return non-NULL and breaks otherwise.
+ Be compatible. */
+
+#if 0
+ if (size == 0)
+ return NULL;
+#endif
+
+ if (size < sizeof (struct list))
+ size = sizeof (struct list);
+
+#ifdef SUNOS_LOCALTIME_BUG
+ if (size < 16)
+ size = 16;
+#endif
+
+ /* Determine the allocation policy based on the request size. */
+ if (size <= BLOCKSIZE / 2)
+ {
+ /* Small allocation to receive a fragment of a block.
+ Determine the logarithm to base two of the fragment size. */
+ register __malloc_size_t log = 1;
+ --size;
+ while ((size /= 2) != 0)
+ ++log;
+
+ /* Look in the fragment lists for a
+ free fragment of the desired size. */
+ next = _fraghead[log].next;
+ if (next != NULL)
+ {
+ /* There are free fragments of this size.
+ Pop a fragment out of the fragment list and return it.
+ Update the block's nfree and first counters. */
+ result = (__ptr_t) next;
+ next->prev->next = next->next;
+ if (next->next != NULL)
+ next->next->prev = next->prev;
+ block = BLOCK (result);
+ if (--_heapinfo[block].busy.info.frag.nfree != 0)
+ _heapinfo[block].busy.info.frag.first = (unsigned long int)
+ ((unsigned long int) ((char *) next->next - (char *) NULL)
+ % BLOCKSIZE) >> log;
+
+ /* Update the statistics. */
+ ++_chunks_used;
+ _bytes_used += 1 << log;
+ --_chunks_free;
+ _bytes_free -= 1 << log;
+ }
+ else
+ {
+ /* No free fragments of the desired size, so get a new block
+ and break it into fragments, returning the first. */
+ result = malloc (BLOCKSIZE);
+ if (result == NULL)
+ return NULL;
+
+ /* Link all fragments but the first into the free list. */
+ next = (struct list *) ((char *) result + (1 << log));
+ next->next = NULL;
+ next->prev = &_fraghead[log];
+ _fraghead[log].next = next;
+
+ for (i = 2; i < (__malloc_size_t) (BLOCKSIZE >> log); ++i)
+ {
+ next = (struct list *) ((char *) result + (i << log));
+ next->next = _fraghead[log].next;
+ next->prev = &_fraghead[log];
+ next->prev->next = next;
+ next->next->prev = next;
+ }
+
+ /* Initialize the nfree and first counters for this block. */
+ block = BLOCK (result);
+ _heapinfo[block].busy.type = log;
+ _heapinfo[block].busy.info.frag.nfree = i - 1;
+ _heapinfo[block].busy.info.frag.first = i - 1;
+
+ _chunks_free += (BLOCKSIZE >> log) - 1;
+ _bytes_free += BLOCKSIZE - (1 << log);
+ _bytes_used -= BLOCKSIZE - (1 << log);
+ }
+ }
+ else
+ {
+ /* Large allocation to receive one or more blocks.
+ Search the free list in a circle starting at the last place visited.
+ If we loop completely around without finding a large enough
+ space we will have to get more memory from the system. */
+ blocks = BLOCKIFY (size);
+ start = block = _heapindex;
+ while (_heapinfo[block].free.size < blocks)
+ {
+ block = _heapinfo[block].free.next;
+ if (block == start)
+ {
+ /* Need to get more from the system. Get a little extra. */
+ __malloc_size_t wantblocks = blocks + __malloc_extra_blocks;
+ block = _heapinfo[0].free.prev;
+ lastblocks = _heapinfo[block].free.size;
+ /* Check to see if the new core will be contiguous with the
+ final free block; if so we don't need to get as much. */
+ if (_heaplimit != 0 && block + lastblocks == _heaplimit &&
+ /* We can't do this if we will have to make the heap info
+ table bigger to accomodate the new space. */
+ block + wantblocks <= heapsize &&
+ get_contiguous_space ((wantblocks - lastblocks) * BLOCKSIZE,
+ ADDRESS (block + lastblocks)))
+ {
+ /* We got it contiguously. Which block we are extending
+ (the `final free block' referred to above) might have
+ changed, if it got combined with a freed info table. */
+ block = _heapinfo[0].free.prev;
+ _heapinfo[block].free.size += (wantblocks - lastblocks);
+ _bytes_free += (wantblocks - lastblocks) * BLOCKSIZE;
+ _heaplimit += wantblocks - lastblocks;
+ continue;
+ }
+ result = morecore (wantblocks * BLOCKSIZE);
+ if (result == NULL)
+ return NULL;
+ block = BLOCK (result);
+ /* Put the new block at the end of the free list. */
+ _heapinfo[block].free.size = wantblocks;
+ _heapinfo[block].free.prev = _heapinfo[0].free.prev;
+ _heapinfo[block].free.next = 0;
+ _heapinfo[0].free.prev = block;
+ _heapinfo[_heapinfo[block].free.prev].free.next = block;
+ ++_chunks_free;
+ /* Now loop to use some of that block for this allocation. */
+ }
+ }
+
+ /* At this point we have found a suitable free list entry.
+ Figure out how to remove what we need from the list. */
+ result = ADDRESS (block);
+ if (_heapinfo[block].free.size > blocks)
+ {
+ /* The block we found has a bit left over,
+ so relink the tail end back into the free list. */
+ _heapinfo[block + blocks].free.size
+ = _heapinfo[block].free.size - blocks;
+ _heapinfo[block + blocks].free.next
+ = _heapinfo[block].free.next;
+ _heapinfo[block + blocks].free.prev
+ = _heapinfo[block].free.prev;
+ _heapinfo[_heapinfo[block].free.prev].free.next
+ = _heapinfo[_heapinfo[block].free.next].free.prev
+ = _heapindex = block + blocks;
+ }
+ else
+ {
+ /* The block exactly matches our requirements,
+ so just remove it from the list. */
+ _heapinfo[_heapinfo[block].free.next].free.prev
+ = _heapinfo[block].free.prev;
+ _heapinfo[_heapinfo[block].free.prev].free.next
+ = _heapindex = _heapinfo[block].free.next;
+ --_chunks_free;
+ }
+
+ _heapinfo[block].busy.type = 0;
+ _heapinfo[block].busy.info.size = blocks;
+ ++_chunks_used;
+ _bytes_used += blocks * BLOCKSIZE;
+ _bytes_free -= blocks * BLOCKSIZE;
+
+ /* Mark all the blocks of the object just allocated except for the
+ first with a negative number so you can find the first block by
+ adding that adjustment. */
+ while (--blocks > 0)
+ _heapinfo[block + blocks].busy.info.size = -blocks;
+ }
+
+ return result;
+}
+
+__ptr_t
+malloc (size)
+ __malloc_size_t size;
+{
+ if (!__malloc_initialized && !__malloc_initialize ())
+ return NULL;
+
+ return (__malloc_hook != NULL ? *__malloc_hook : _malloc_internal) (size);
+}
+
+#ifndef _LIBC
+
+/* On some ANSI C systems, some libc functions call _malloc, _free
+ and _realloc. Make them use the GNU functions. */
+
+__ptr_t
+_malloc (size)
+ __malloc_size_t size;
+{
+ return malloc (size);
+}
+
+void
+_free (ptr)
+ __ptr_t ptr;
+{
+ free (ptr);
+}
+
+__ptr_t
+_realloc (ptr, size)
+ __ptr_t ptr;
+ __malloc_size_t size;
+{
+ return realloc (ptr, size);
+}
+
+#endif
+/* Free a block of memory allocated by `malloc'.
+ Copyright 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc.
+ Written May 1989 by Mike Haertel.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+
+/* Cope with systems lacking `memmove'. */
+#ifndef memmove
+#if (defined (MEMMOVE_MISSING) || \
+ !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG))
+#ifdef emacs
+#undef __malloc_safe_bcopy
+#define __malloc_safe_bcopy safe_bcopy
+#endif
+/* This function is defined in realloc.c. */
+extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t));
+#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size))
+#endif
+#endif
+
+
+/* Debugging hook for free. */
+void (*__free_hook) __P ((__ptr_t __ptr));
+
+/* List of blocks allocated by memalign. */
+struct alignlist *_aligned_blocks = NULL;
+
+/* Return memory to the heap.
+ Like `free' but don't call a __free_hook if there is one. */
+void
+_free_internal (ptr)
+ __ptr_t ptr;
+{
+ int type;
+ __malloc_size_t block, blocks;
+ register __malloc_size_t i;
+ struct list *prev, *next;
+ __ptr_t curbrk;
+ const __malloc_size_t lesscore_threshold
+ /* Threshold of free space at which we will return some to the system. */
+ = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks;
+
+ register struct alignlist *l;
+
+ if (ptr == NULL)
+ return;
+
+ for (l = _aligned_blocks; l != NULL; l = l->next)
+ if (l->aligned == ptr)
+ {
+ l->aligned = NULL; /* Mark the slot in the list as free. */
+ ptr = l->exact;
+ break;
+ }
+
+ block = BLOCK (ptr);
+
+ type = _heapinfo[block].busy.type;
+ switch (type)
+ {
+ case 0:
+ /* Get as many statistics as early as we can. */
+ --_chunks_used;
+ _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE;
+ _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE;
+
+ /* Find the free cluster previous to this one in the free list.
+ Start searching at the last block referenced; this may benefit
+ programs with locality of allocation. */
+ i = _heapindex;
+ if (i > block)
+ while (i > block)
+ i = _heapinfo[i].free.prev;
+ else
+ {
+ do
+ i = _heapinfo[i].free.next;
+ while (i > 0 && i < block);
+ i = _heapinfo[i].free.prev;
+ }
+
+ /* Determine how to link this block into the free list. */
+ if (block == i + _heapinfo[i].free.size)
+ {
+ /* Coalesce this block with its predecessor. */
+ _heapinfo[i].free.size += _heapinfo[block].busy.info.size;
+ block = i;
+ }
+ else
+ {
+ /* Really link this block back into the free list. */
+ _heapinfo[block].free.size = _heapinfo[block].busy.info.size;
+ _heapinfo[block].free.next = _heapinfo[i].free.next;
+ _heapinfo[block].free.prev = i;
+ _heapinfo[i].free.next = block;
+ _heapinfo[_heapinfo[block].free.next].free.prev = block;
+ ++_chunks_free;
+ }
+
+ /* Now that the block is linked in, see if we can coalesce it
+ with its successor (by deleting its successor from the list
+ and adding in its size). */
+ if (block + _heapinfo[block].free.size == _heapinfo[block].free.next)
+ {
+ _heapinfo[block].free.size
+ += _heapinfo[_heapinfo[block].free.next].free.size;
+ _heapinfo[block].free.next
+ = _heapinfo[_heapinfo[block].free.next].free.next;
+ _heapinfo[_heapinfo[block].free.next].free.prev = block;
+ --_chunks_free;
+ }
+
+ /* How many trailing free blocks are there now? */
+ blocks = _heapinfo[block].free.size;
+
+ /* Where is the current end of accessible core? */
+ curbrk = (*__morecore) (0);
+
+ if (_heaplimit != 0 && curbrk == ADDRESS (_heaplimit))
+ {
+ /* The end of the malloc heap is at the end of accessible core.
+ It's possible that moving _heapinfo will allow us to
+ return some space to the system. */
+
+ __malloc_size_t info_block = BLOCK (_heapinfo);
+ __malloc_size_t info_blocks = _heapinfo[info_block].busy.info.size;
+ __malloc_size_t prev_block = _heapinfo[block].free.prev;
+ __malloc_size_t prev_blocks = _heapinfo[prev_block].free.size;
+ __malloc_size_t next_block = _heapinfo[block].free.next;
+ __malloc_size_t next_blocks = _heapinfo[next_block].free.size;
+
+ if (/* Win if this block being freed is last in core, the info table
+ is just before it, the previous free block is just before the
+ info table, and the two free blocks together form a useful
+ amount to return to the system. */
+ (block + blocks == _heaplimit &&
+ info_block + info_blocks == block &&
+ prev_block != 0 && prev_block + prev_blocks == info_block &&
+ blocks + prev_blocks >= lesscore_threshold) ||
+ /* Nope, not the case. We can also win if this block being
+ freed is just before the info table, and the table extends
+ to the end of core or is followed only by a free block,
+ and the total free space is worth returning to the system. */
+ (block + blocks == info_block &&
+ ((info_block + info_blocks == _heaplimit &&
+ blocks >= lesscore_threshold) ||
+ (info_block + info_blocks == next_block &&
+ next_block + next_blocks == _heaplimit &&
+ blocks + next_blocks >= lesscore_threshold)))
+ )
+ {
+ malloc_info *newinfo;
+ __malloc_size_t oldlimit = _heaplimit;
+
+ /* Free the old info table, clearing _heaplimit to avoid
+ recursion into this code. We don't want to return the
+ table's blocks to the system before we have copied them to
+ the new location. */
+ _heaplimit = 0;
+ _free_internal (_heapinfo);
+ _heaplimit = oldlimit;
+
+ /* Tell malloc to search from the beginning of the heap for
+ free blocks, so it doesn't reuse the ones just freed. */
+ _heapindex = 0;
+
+ /* Allocate new space for the info table and move its data. */
+ newinfo = (malloc_info *) _malloc_internal (info_blocks
+ * BLOCKSIZE);
+ memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE);
+ _heapinfo = newinfo;
+
+ /* We should now have coalesced the free block with the
+ blocks freed from the old info table. Examine the entire
+ trailing free block to decide below whether to return some
+ to the system. */
+ block = _heapinfo[0].free.prev;
+ blocks = _heapinfo[block].free.size;
+ }
+
+ /* Now see if we can return stuff to the system. */
+ if (block + blocks == _heaplimit && blocks >= lesscore_threshold)
+ {
+ register __malloc_size_t bytes = blocks * BLOCKSIZE;
+ _heaplimit -= blocks;
+ (*__morecore) (-bytes);
+ _heapinfo[_heapinfo[block].free.prev].free.next
+ = _heapinfo[block].free.next;
+ _heapinfo[_heapinfo[block].free.next].free.prev
+ = _heapinfo[block].free.prev;
+ block = _heapinfo[block].free.prev;
+ --_chunks_free;
+ _bytes_free -= bytes;
+ }
+ }
+
+ /* Set the next search to begin at this block. */
+ _heapindex = block;
+ break;
+
+ default:
+ /* Do some of the statistics. */
+ --_chunks_used;
+ _bytes_used -= 1 << type;
+ ++_chunks_free;
+ _bytes_free += 1 << type;
+
+ /* Get the address of the first free fragment in this block. */
+ prev = (struct list *) ((char *) ADDRESS (block) +
+ (_heapinfo[block].busy.info.frag.first << type));
+
+ if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1)
+ {
+ /* If all fragments of this block are free, remove them
+ from the fragment list and free the whole block. */
+ next = prev;
+ for (i = 1; i < (__malloc_size_t) (BLOCKSIZE >> type); ++i)
+ next = next->next;
+ prev->prev->next = next;
+ if (next != NULL)
+ next->prev = prev->prev;
+ _heapinfo[block].busy.type = 0;
+ _heapinfo[block].busy.info.size = 1;
+
+ /* Keep the statistics accurate. */
+ ++_chunks_used;
+ _bytes_used += BLOCKSIZE;
+ _chunks_free -= BLOCKSIZE >> type;
+ _bytes_free -= BLOCKSIZE;
+
+ free (ADDRESS (block));
+ }
+ else if (_heapinfo[block].busy.info.frag.nfree != 0)
+ {
+ /* If some fragments of this block are free, link this
+ fragment into the fragment list after the first free
+ fragment of this block. */
+ next = (struct list *) ptr;
+ next->next = prev->next;
+ next->prev = prev;
+ prev->next = next;
+ if (next->next != NULL)
+ next->next->prev = next;
+ ++_heapinfo[block].busy.info.frag.nfree;
+ }
+ else
+ {
+ /* No fragments of this block are free, so link this
+ fragment into the fragment list and announce that
+ it is the first free fragment of this block. */
+ prev = (struct list *) ptr;
+ _heapinfo[block].busy.info.frag.nfree = 1;
+ _heapinfo[block].busy.info.frag.first = (unsigned long int)
+ ((unsigned long int) ((char *) ptr - (char *) NULL)
+ % BLOCKSIZE >> type);
+ prev->next = _fraghead[type].next;
+ prev->prev = &_fraghead[type];
+ prev->prev->next = prev;
+ if (prev->next != NULL)
+ prev->next->prev = prev;
+ }
+ break;
+ }
+}
+
+/* Return memory to the heap. */
+void
+free (ptr)
+ __ptr_t ptr;
+{
+ if (__free_hook != NULL)
+ (*__free_hook) (ptr);
+ else
+ _free_internal (ptr);
+}
+
+/* Define the `cfree' alias for `free'. */
+#ifdef weak_alias
+weak_alias (free, cfree)
+#else
+void
+cfree (ptr)
+ __ptr_t ptr;
+{
+ free (ptr);
+}
+#endif
+/* Change the size of a block allocated by `malloc'.
+ Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ Written May 1989 by Mike Haertel.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+
+
+/* Cope with systems lacking `memmove'. */
+#if (defined (MEMMOVE_MISSING) || \
+ !defined(_LIBC) && !defined(STDC_HEADERS) && !defined(USG))
+
+#ifdef emacs
+#undef __malloc_safe_bcopy
+#define __malloc_safe_bcopy safe_bcopy
+#else
+
+/* Snarfed directly from Emacs src/dispnew.c:
+ XXX Should use system bcopy if it handles overlap. */
+
+/* Like bcopy except never gets confused by overlap. */
+
+void
+__malloc_safe_bcopy (afrom, ato, size)
+ __ptr_t afrom;
+ __ptr_t ato;
+ __malloc_size_t size;
+{
+ char *from = afrom, *to = ato;
+
+ if (size <= 0 || from == to)
+ return;
+
+ /* If the source and destination don't overlap, then bcopy can
+ handle it. If they do overlap, but the destination is lower in
+ memory than the source, we'll assume bcopy can handle that. */
+ if (to < from || from + size <= to)
+ bcopy (from, to, size);
+
+ /* Otherwise, we'll copy from the end. */
+ else
+ {
+ register char *endf = from + size;
+ register char *endt = to + size;
+
+ /* If TO - FROM is large, then we should break the copy into
+ nonoverlapping chunks of TO - FROM bytes each. However, if
+ TO - FROM is small, then the bcopy function call overhead
+ makes this not worth it. The crossover point could be about
+ anywhere. Since I don't think the obvious copy loop is too
+ bad, I'm trying to err in its favor. */
+ if (to - from < 64)
+ {
+ do
+ *--endt = *--endf;
+ while (endf != from);
+ }
+ else
+ {
+ for (;;)
+ {
+ endt -= (to - from);
+ endf -= (to - from);
+
+ if (endt < to)
+ break;
+
+ bcopy (endf, endt, to - from);
+ }
+
+ /* If SIZE wasn't a multiple of TO - FROM, there will be a
+ little left over. The amount left over is
+ (endt + (to - from)) - to, which is endt - from. */
+ bcopy (from, to, endt - from);
+ }
+ }
+}
+#endif /* emacs */
+
+#ifndef memmove
+extern void __malloc_safe_bcopy __P ((__ptr_t, __ptr_t, __malloc_size_t));
+#define memmove(to, from, size) __malloc_safe_bcopy ((from), (to), (size))
+#endif
+
+#endif
+
+
+#define min(A, B) ((A) < (B) ? (A) : (B))
+
+/* Debugging hook for realloc. */
+__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, __malloc_size_t __size));
+
+/* Resize the given region to the new size, returning a pointer
+ to the (possibly moved) region. This is optimized for speed;
+ some benchmarks seem to indicate that greater compactness is
+ achieved by unconditionally allocating and copying to a
+ new region. This module has incestuous knowledge of the
+ internals of both free and malloc. */
+__ptr_t
+_realloc_internal (ptr, size)
+ __ptr_t ptr;
+ __malloc_size_t size;
+{
+ __ptr_t result;
+ int type;
+ __malloc_size_t block, blocks, oldlimit;
+
+ if (size == 0)
+ {
+ _free_internal (ptr);
+ return _malloc_internal (0);
+ }
+ else if (ptr == NULL)
+ return _malloc_internal (size);
+
+ block = BLOCK (ptr);
+
+ type = _heapinfo[block].busy.type;
+ switch (type)
+ {
+ case 0:
+ /* Maybe reallocate a large block to a small fragment. */
+ if (size <= BLOCKSIZE / 2)
+ {
+ result = _malloc_internal (size);
+ if (result != NULL)
+ {
+ memcpy (result, ptr, size);
+ _free_internal (ptr);
+ return result;
+ }
+ }
+
+ /* The new size is a large allocation as well;
+ see if we can hold it in place. */
+ blocks = BLOCKIFY (size);
+ if (blocks < _heapinfo[block].busy.info.size)
+ {
+ /* The new size is smaller; return
+ excess memory to the free list. */
+ _heapinfo[block + blocks].busy.type = 0;
+ _heapinfo[block + blocks].busy.info.size
+ = _heapinfo[block].busy.info.size - blocks;
+ _heapinfo[block].busy.info.size = blocks;
+ /* We have just created a new chunk by splitting a chunk in two.
+ Now we will free this chunk; increment the statistics counter
+ so it doesn't become wrong when _free_internal decrements it. */
+ ++_chunks_used;
+ _free_internal (ADDRESS (block + blocks));
+ result = ptr;
+ }
+ else if (blocks == _heapinfo[block].busy.info.size)
+ /* No size change necessary. */
+ result = ptr;
+ else
+ {
+ /* Won't fit, so allocate a new region that will.
+ Free the old region first in case there is sufficient
+ adjacent free space to grow without moving. */
+ blocks = _heapinfo[block].busy.info.size;
+ /* Prevent free from actually returning memory to the system. */
+ oldlimit = _heaplimit;
+ _heaplimit = 0;
+ _free_internal (ptr);
+ result = _malloc_internal (size);
+ if (_heaplimit == 0)
+ _heaplimit = oldlimit;
+ if (result == NULL)
+ {
+ /* Now we're really in trouble. We have to unfree
+ the thing we just freed. Unfortunately it might
+ have been coalesced with its neighbors. */
+ if (_heapindex == block)
+ (void) _malloc_internal (blocks * BLOCKSIZE);
+ else
+ {
+ __ptr_t previous
+ = _malloc_internal ((block - _heapindex) * BLOCKSIZE);
+ (void) _malloc_internal (blocks * BLOCKSIZE);
+ _free_internal (previous);
+ }
+ return NULL;
+ }
+ if (ptr != result)
+ memmove (result, ptr, blocks * BLOCKSIZE);
+ }
+ break;
+
+ default:
+ /* Old size is a fragment; type is logarithm
+ to base two of the fragment size. */
+ if (size > (__malloc_size_t) (1 << (type - 1)) &&
+ size <= (__malloc_size_t) (1 << type))
+ /* The new size is the same kind of fragment. */
+ result = ptr;
+ else
+ {
+ /* The new size is different; allocate a new space,
+ and copy the lesser of the new size and the old. */
+ result = _malloc_internal (size);
+ if (result == NULL)
+ return NULL;
+ memcpy (result, ptr, min (size, (__malloc_size_t) 1 << type));
+ _free_internal (ptr);
+ }
+ break;
+ }
+
+ return result;
+}
+
+__ptr_t
+realloc (ptr, size)
+ __ptr_t ptr;
+ __malloc_size_t size;
+{
+ if (!__malloc_initialized && !__malloc_initialize ())
+ return NULL;
+
+ return (__realloc_hook != NULL ? *__realloc_hook : _realloc_internal)
+ (ptr, size);
+}
+/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+/* Allocate an array of NMEMB elements each SIZE bytes long.
+ The entire array is initialized to zeros. */
+__ptr_t
+calloc (nmemb, size)
+ register __malloc_size_t nmemb;
+ register __malloc_size_t size;
+{
+ register __ptr_t result = malloc (nmemb * size);
+
+ if (result != NULL)
+ (void) memset (result, 0, nmemb * size);
+
+ return result;
+}
+/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+This file is part of the GNU C Library.
+
+The GNU C Library is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+The GNU C Library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with the GNU C Library; see the file COPYING. If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+#ifndef __GNU_LIBRARY__
+#define __sbrk sbrk
+#endif
+
+#ifdef __GNU_LIBRARY__
+/* It is best not to declare this and cast its result on foreign operating
+ systems with potentially hostile include files. */
+
+#include <stddef.h>
+extern __ptr_t __sbrk __P ((ptrdiff_t increment));
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+/* Allocate INCREMENT more bytes of data space,
+ and return the start of data space, or NULL on errors.
+ If INCREMENT is negative, shrink data space. */
+__ptr_t
+__default_morecore (increment)
+ __malloc_ptrdiff_t increment;
+{
+ __ptr_t result = (__ptr_t) __sbrk (increment);
+ if (result == (__ptr_t) -1)
+ return NULL;
+ return result;
+}
+/* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA. */
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+#if __DJGPP__ - 0 == 1
+
+/* There is some problem with memalign in DJGPP v1 and we are supposed
+ to omit it. Noone told me why, they just told me to do it. */
+
+#else
+
+__ptr_t (*__memalign_hook) __P ((size_t __size, size_t __alignment));
+
+__ptr_t
+memalign (alignment, size)
+ __malloc_size_t alignment;
+ __malloc_size_t size;
+{
+ __ptr_t result;
+ unsigned long int adj, lastadj;
+
+ if (__memalign_hook)
+ return (*__memalign_hook) (alignment, size);
+
+ /* Allocate a block with enough extra space to pad the block with up to
+ (ALIGNMENT - 1) bytes if necessary. */
+ result = malloc (size + alignment - 1);
+ if (result == NULL)
+ return NULL;
+
+ /* Figure out how much we will need to pad this particular block
+ to achieve the required alignment. */
+ adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment;
+
+ do
+ {
+ /* Reallocate the block with only as much excess as it needs. */
+ free (result);
+ result = malloc (adj + size);
+ if (result == NULL) /* Impossible unless interrupted. */
+ return NULL;
+
+ lastadj = adj;
+ adj = (unsigned long int) ((char *) result - (char *) NULL) % alignment;
+ /* It's conceivable we might have been so unlucky as to get a
+ different block with weaker alignment. If so, this block is too
+ short to contain SIZE after alignment correction. So we must
+ try again and get another block, slightly larger. */
+ } while (adj > lastadj);
+
+ if (adj != 0)
+ {
+ /* Record this block in the list of aligned blocks, so that `free'
+ can identify the pointer it is passed, which will be in the middle
+ of an allocated block. */
+
+ struct alignlist *l;
+ for (l = _aligned_blocks; l != NULL; l = l->next)
+ if (l->aligned == NULL)
+ /* This slot is free. Use it. */
+ break;
+ if (l == NULL)
+ {
+ l = (struct alignlist *) malloc (sizeof (struct alignlist));
+ if (l == NULL)
+ {
+ free (result);
+ return NULL;
+ }
+ l->next = _aligned_blocks;
+ _aligned_blocks = l;
+ }
+ l->exact = result;
+ result = l->aligned = (char *) result + alignment - adj;
+ }
+
+ return result;
+}
+
+#endif /* Not DJGPP v1 */
+/* Allocate memory on a page boundary.
+ Copyright (C) 1991, 92, 93, 94, 96 Free Software Foundation, Inc.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; see the file COPYING.LIB. If
+not, write to the Free Software Foundation, Inc., 675 Mass Ave,
+Cambridge, MA 02139, USA.
+
+ The author may be reached (Email) at the address mike@ai.mit.edu,
+ or (US mail) as Mike Haertel c/o Free Software Foundation. */
+
+#if defined (_MALLOC_INTERNAL) && defined (GMALLOC_INHIBIT_VALLOC)
+
+/* Emacs defines GMALLOC_INHIBIT_VALLOC to avoid this definition
+ on MSDOS, where it conflicts with a system header file. */
+
+#define ELIDE_VALLOC
+
+#endif
+
+#ifndef ELIDE_VALLOC
+
+#if defined (__GNU_LIBRARY__) || defined (_LIBC)
+#include <stddef.h>
+#include <sys/cdefs.h>
+extern size_t __getpagesize __P ((void));
+#else
+#include "getpagesize.h"
+#define __getpagesize() getpagesize()
+#endif
+
+#ifndef _MALLOC_INTERNAL
+#define _MALLOC_INTERNAL
+#include <malloc.h>
+#endif
+
+static __malloc_size_t pagesize;
+
+__ptr_t
+valloc (size)
+ __malloc_size_t size;
+{
+ if (pagesize == 0)
+ pagesize = __getpagesize ();
+
+ return memalign (pagesize, size);
+}
+
+#endif /* Not ELIDE_VALLOC. */
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 <sys/types.h>
+#endif
+
+#ifndef THINK_C
+# ifdef vms
+# include <stat.h>
+# else
+# include <sys/stat.h>
+# endif
+# ifdef __TURBOC__
+# include <io.h>
+# endif
+SCM stat2scm P((struct stat *stat_temp));
+/* int mkdir P((const char *path, mode_t mode)); */
+#endif
+#ifdef hpux
+# include <unistd.h>
+#endif
+#ifdef __sgi__
+# include <unistd.h>
+#endif
+
+#ifndef STDC_HEADERS
+ int chdir P((const char *path));
+ int unlink P((const char *name));
+ int link P((const char *from, const char *to));
+ char *getcwd P((char *buf, sizet size));
+ int access P((const char *name, int type));
+ int dup P((int fd));
+ int dup2 P((int fd, int fd2));
+ int close P((int fd));
+ int rmdir P((const char *path));
+ int execv P((const char *, char *const *));
+ int execvp P((const char *, char *const *));
+ int putenv P((const char *));
+#else
+# ifdef _WIN32
+# include <direct.h>
+# include <io.h>
+# include <process.h>
+# endif
+# ifdef __HIGHC__
+# include <direct.h>
+# include <dirent.h>
+# include <process.h>
+# define mkdir(foo,bar) mkdir(foo)
+# endif
+#endif /* STDC_HEADERS */
+
+#ifdef __EMX__
+ int execv P((const char *, char *const *));
+ int execvp P((const char *, char *const *));
+ int putenv P((const char *));
+#endif
+
+static char s_read_line[] = "read-line";
+SCM read_line(port)
+ SCM port;
+{
+ register int c;
+ register int j = 0;
+ sizet len = 30;
+ SCM tok_buf = makstr((long) len);
+ register char *p = CHARS(tok_buf);
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_line);
+ if (EOF==(c = lgetc(port))) return EOF_VAL;
+ while(1) {
+ switch (c) {
+ case LINE_INCREMENTORS:
+ case EOF:
+ if (len==j) return tok_buf;
+ return resizuve(tok_buf, (SCM)MAKINUM(j));
+ default:
+ if (j >= len) {
+ p = grow_tok_buf(tok_buf);
+ len = LENGTH(tok_buf);
+ }
+ p[j++] = c;
+ c = lgetc(port);
+ }
+ }
+}
+static char s_read_line1[] = "read-line!";
+SCM read_line1(str, port)
+ SCM str, port;
+{
+ register int c;
+ register int j = 0;
+ register char *p;
+ sizet len;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_read_line1);
+ p = CHARS(str);
+ len = LENGTH(str);
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG2, s_read_line1);
+ c = lgetc(port);
+ if (EOF==c) return EOF_VAL;
+ while(1) {
+ switch (c) {
+ case LINE_INCREMENTORS:
+ case EOF:
+ return MAKINUM(j);
+ default:
+ if (j >= len) {
+ lungetc(c, port);
+ return BOOL_F;
+ }
+ p[j++] = c;
+ c = lgetc(port);
+ }
+ }
+}
+static char s_write_line[] = "write-line";
+SCM l_write_line(obj, port)
+ SCM obj, port;
+{
+ display(obj, port);
+ return newline(port);
+}
+
+static char s_file_position[] = "file-position",
+ s_file_set_pos[] = "file-set-position";
+SCM file_position(port)
+ SCM port;
+{
+ long ans;
+ ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_position);
+ SYSCALL(ans = ftell(STREAM(port)););
+ if CRDYP(port) ans--;
+ return MAKINUM(ans);
+ }
+SCM file_set_position(port, pos)
+ SCM port, pos;
+{
+ SCM ans;
+ ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
+ CLRDY(port); /* Clear ungetted char */
+ SYSCALL(ans = (fseek(STREAM(port), INUM(pos), 0)) ? BOOL_F : BOOL_T;);
+#ifdef HAVE_PIPE
+# ifdef ESPIPE
+ if (!OPIOPORTP(port))
+ ASSERT(ESPIPE != errno, port, ARG1, s_file_set_pos);
+# endif
+#endif
+ return ans;
+}
+
+static char s_reopen_file[] = "reopen-file";
+SCM reopen_file(filename, modes, port)
+ SCM filename, modes, port;
+{
+ FILE *f;
+ ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
+ ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_reopen_file);
+ DEFER_INTS;
+ ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
+ SYSCALL(f = freopen(CHARS(filename), CHARS(modes), STREAM(port)););
+ if (!f) port = BOOL_F;
+ else {
+ SETSTREAM(port, f);
+ if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes))))
+ i_setbuf0(port);
+ }
+ ALLOW_INTS;
+ return port;
+}
+
+#ifndef MCH_AMIGA
+
+static char s_dup[]="duplicate-port";
+SCM l_dup(oldpt, modes)
+ SCM oldpt, modes;
+{
+ int tfd;
+ FILE *f;
+ SCM newpt;
+ ASSERT(NIMP(oldpt) && OPPORTP(oldpt), oldpt, ARG1, s_dup);
+ ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_dup);
+ NEWCELL(newpt);
+ DEFER_INTS;
+ SYSCALL(tfd = dup(fileno(STREAM(oldpt))););
+ if (-1==tfd) {ALLOW_INTS;return BOOL_F;};
+ SYSCALL(f = fdopen(tfd, CHARS(modes)););
+ if (!f) {
+ close(tfd);
+ wta(MAKINUM(tfd), (char *)NALLOC, s_port_type);
+ }
+ SETSTREAM(newpt, f);
+ if (BUF0 & (CAR(newpt) = tc16_fport | mode_bits(CHARS(modes))))
+ i_setbuf0(newpt);
+ ALLOW_INTS;
+ return newpt;
+}
+static char s_dup2[]="redirect-port!";
+SCM l_dup2(into_pt, from_pt)
+ SCM into_pt, from_pt;
+{
+ int ans, oldfd, newfd;
+ DEFER_INTS;
+ ASSERT(NIMP(into_pt) && OPPORTP(into_pt), into_pt, ARG1, s_dup2);
+ ASSERT(NIMP(from_pt) && OPPORTP(from_pt), from_pt, ARG1, s_dup2);
+ oldfd = fileno(STREAM(into_pt));
+ newfd = fileno(STREAM(from_pt));
+ SYSCALL(ans = dup2(oldfd, newfd););
+ if (-1==ans) {ALLOW_INTS;return BOOL_F;};
+ ALLOW_INTS;
+ return into_pt;
+}
+
+# ifndef vms
+# ifndef _WIN32
+# include <dirent.h>
+static char s_opendir[]="opendir";
+SCM l_opendir(dirname)
+ SCM dirname;
+{
+ DIR *ds;
+ SCM dir;
+ ASSERT(NIMP(dirname) && STRINGP(dirname), dirname, ARG1, s_opendir);
+ NEWCELL(dir);
+ DEFER_INTS;
+ SYSCALL(ds = opendir(CHARS(dirname)););
+ if (!ds) {ALLOW_INTS; return BOOL_F;}
+ CAR(dir) = tc16_dir | OPN;
+ SETCDR(dir, ds);
+ ALLOW_INTS;
+ return dir;
+}
+static char s_readdir[]="readdir";
+SCM l_readdir(port)
+ SCM port;
+{
+ struct dirent *rdent;
+ DEFER_INTS;
+ ASSERT(OPDIRP(port), port, ARG1, s_readdir);
+ SYSCALL(rdent = readdir((DIR *)CDR(port)););
+ if (!rdent) {ALLOW_INTS; return BOOL_F;}
+ ALLOW_INTS;
+ /* rdent could be overwritten by another readdir to the same handle */
+ return makfrom0str(rdent->d_name);
+}
+static char s_rewinddir[]="rewinddir";
+SCM l_rewinddir(port)
+ SCM port;
+{
+ ASSERT(OPDIRP(port), port, ARG1, s_rewinddir);
+ rewinddir((DIR *)CDR(port));
+ return UNSPECIFIED;
+}
+static char s_closedir[]="closedir";
+SCM l_closedir(port)
+ SCM port;
+{
+ int sts;
+ ASSERT(DIRP(port), port, ARG1, s_closedir);
+ DEFER_INTS;
+ if CLOSEDP(port) {ALLOW_INTS;return BOOL_F;}
+ SYSCALL(sts = closedir((DIR *)CDR(port)););
+ if (sts) {ALLOW_INTS; return BOOL_F;}
+ CAR(port) = tc16_dir;
+ ALLOW_INTS;
+ return BOOL_T;
+}
+
+int dir_print(sexp, port, writing)
+ SCM sexp; SCM port; int writing;
+{
+ prinport(sexp, port, "directory");
+ return !0;
+}
+sizet dir_free(p)
+ CELLPTR p;
+{
+ if OPENP((SCM)p) closedir((DIR *)CDR((SCM)p));
+ return 0;
+}
+
+long tc16_dir;
+static smobfuns dir_smob = {mark0, dir_free, dir_print, 0};
+# endif /* _WIN32 */
+# endif /* vms */
+
+static char s_mkdir[] = "mkdir";
+SCM l_mkdir(path, mode)
+ SCM path, mode;
+{
+ int val;
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mkdir);
+ ASSERT(INUMP(mode), mode, ARG2, s_mkdir);
+# ifdef _WIN32
+ SYSCALL(val = mkdir(CHARS(path)););
+# else
+ SYSCALL(val = mkdir(CHARS(path), INUM(mode)););
+ /* (mode_t)INUM(mode) might be needed */
+# endif
+ return val ? BOOL_F : BOOL_T;
+}
+# ifdef vms
+static char s_dot_dir[] = ".DIR";
+# endif
+static char s_rmdir[] = "rmdir";
+SCM l_rmdir(path)
+ SCM path;
+{
+ int val;
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_rmdir);
+# ifdef vms
+ return del_fil(st_append(cons2(path, s_dot_dir, EOL)));
+# else
+ SYSCALL(val = rmdir(CHARS(path)););
+ return val ? BOOL_F : BOOL_T;
+# endif
+}
+#endif /* MCH_AMIGA */
+
+#ifndef THINK_C
+static char s_chdir[] = "chdir";
+SCM lchdir(str)
+ SCM str;
+{
+ int ans;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_chdir);
+ SYSCALL(ans = chdir(CHARS(str)););
+ return ans ? BOOL_F : BOOL_T;
+}
+# ifndef MCH_AMIGA
+# ifdef __TURBOC__
+# include <dir.h>
+# endif
+SCM l_getcwd()
+{
+ char *ans;
+# ifndef vms
+ char wd[256];
+ SYSCALL(ans = getcwd(wd, 256););
+ return ans ? makfrom0str(wd) : BOOL_F;
+# else
+ SYSCALL(ans = getenv("PATH"););
+ return ans ? makfrom0str(ans) : BOOL_F;
+# endif
+}
+
+static char s_chmod[] = "chmod";
+SCM l_chmod(pathname, mode)
+ SCM pathname, mode;
+{
+ int val;
+ ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_chmod);
+ ASSERT(INUMP(mode), mode, ARG2, s_chmod);
+ SYSCALL(val = chmod(CHARS(pathname), INUM(mode)););
+ return val ? BOOL_F : BOOL_T;
+}
+
+# ifndef vms
+# ifdef __EMX__
+# include <sys/utime.h>
+# else
+# ifdef _WIN32
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
+# endif
+static char s_utime[] = "utime";
+SCM l_utime(pathname, acctime, modtime)
+ SCM pathname, acctime, modtime;
+{
+ int val;
+ struct utimbuf utm_tmp;
+ utm_tmp.actime = num2ulong(acctime, (char *)ARG2, s_utime);
+ utm_tmp.modtime = num2ulong(modtime, (char *)ARG3, s_utime);
+ ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_utime);
+ SYSCALL(val = utime(CHARS(pathname), &utm_tmp););
+ return val ? BOOL_F : BOOL_T;
+}
+# endif /* vms */
+
+static char s_umask[] = "umask";
+SCM l_umask(mode)
+ SCM mode;
+{
+ ASSERT(INUMP(mode), mode, ARG1, s_umask);
+ return MAKINUM(umask(INUM(mode)));
+}
+# endif /* MCH_AMIGA */
+#endif /* THINK_C */
+
+static char s_ren_fil[] = "rename-file";
+SCM ren_fil(oldname, newname)
+ SCM oldname, newname;
+{
+ SCM ans;
+ ASSERT(NIMP(oldname) && STRINGP(oldname), oldname, ARG1, s_ren_fil);
+ ASSERT(NIMP(newname) && STRINGP(newname), newname, ARG2, s_ren_fil);
+#ifdef STDC_HEADERS
+ SYSCALL(ans = (rename(CHARS(oldname), CHARS(newname))) ? BOOL_F: BOOL_T;);
+ return ans;
+#else
+ DEFER_INTS;
+ SYSCALL(ans = link(CHARS(oldname), CHARS(newname)) ? BOOL_F : BOOL_T;);
+ if (!FALSEP(ans)) {
+ SYSCALL(ans = unlink(CHARS(oldname)) ? BOOL_F : BOOL_T;);
+ if FALSEP(ans)
+ SYSCALL(unlink(CHARS(newname));); /* unlink failed. remove new name */
+ }
+ ALLOW_INTS;
+ return ans;
+#endif
+}
+static char s_fileno[] = "fileno";
+SCM l_fileno(port)
+ SCM port;
+{
+ ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_fileno);
+ if (tc16_fport != TYP16(port)) return BOOL_F;
+ return MAKINUM(fileno(STREAM(port)));
+}
+static char s_isatty[] = "isatty?";
+SCM l_isatty(port)
+ SCM port;
+{
+ ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_isatty);
+ if (tc16_fport != TYP16(port)) return BOOL_F;
+ return isatty(fileno(STREAM(port)))?BOOL_T:BOOL_F;
+}
+#ifndef F_OK
+# define F_OK 00
+# define X_OK 01
+# define W_OK 02
+# define R_OK 04
+#endif
+static char s_access[] = "access";
+SCM l_access(pathname, mode)
+ SCM pathname, mode;
+{
+ int val;
+ int imodes;
+ ASSERT(NIMP(pathname) && STRINGP(pathname), pathname, ARG1, s_access);
+ if INUMP(mode) imodes = INUM(mode);
+ else {
+ ASSERT(NIMP(mode) && STRINGP(mode), mode, ARG2, s_access);
+ imodes = F_OK | (strchr(CHARS(mode), 'r') ? R_OK : 0)
+ | (strchr(CHARS(mode), 'w') ? W_OK : 0)
+ | (strchr(CHARS(mode), 'x') ? X_OK : 0);
+ }
+ SYSCALL(val = access(CHARS(pathname), imodes););
+ return val ? BOOL_F : BOOL_T;
+}
+
+#ifndef THINK_C
+
+char s_stat[] = "stat";
+SCM l_stat(str)
+ SCM str;
+{
+ int i;
+ struct stat stat_temp;
+ if IMP(str)
+ badarg1: wta(str, (char *)ARG1, s_stat);
+ if STRINGP(str) {SYSCALL(i = stat(CHARS(str), &stat_temp););}
+ else {
+# ifndef MCH_AMIGA
+ if (!OPFPORTP(str)) goto badarg1;
+ SYSCALL(i = fstat(fileno(STREAM(str)), &stat_temp););
+# else
+ goto badarg1;
+# endif
+ }
+ if (i) return BOOL_F;
+ return stat2scm(&stat_temp);
+}
+# ifdef MCH_AMIGA
+SCM stat2scm(stat_temp)
+ struct stat *stat_temp;
+{
+ SCM ans = make_vector(MAKINUM(3), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ ve[ 0] = ulong2num((unsigned long)stat_temp->st_attr);
+ ve[ 1] = ulong2num((unsigned long)stat_temp->st_mtime);
+ ve[ 2] = ulong2num((unsigned long)stat_temp->st_size);
+ return ans;
+}
+# else
+SCM stat2scm(stat_temp)
+ struct stat *stat_temp;
+{
+ SCM ans = make_vector(MAKINUM(11), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ ve[ 0] = ulong2num((unsigned long)stat_temp->st_dev);
+ ve[ 1] = ulong2num((unsigned long)stat_temp->st_ino);
+ ve[ 2] = ulong2num((unsigned long)stat_temp->st_mode);
+ ve[ 3] = ulong2num((unsigned long)stat_temp->st_nlink);
+ ve[ 4] = ulong2num((unsigned long)stat_temp->st_uid);
+ ve[ 5] = ulong2num((unsigned long)stat_temp->st_gid);
+ ve[ 6] = ulong2num((unsigned long)stat_temp->st_rdev);
+ ve[ 7] = ulong2num((unsigned long)stat_temp->st_size);
+ ve[ 8] = ulong2num((unsigned long)stat_temp->st_atime);
+ ve[ 9] = ulong2num((unsigned long)stat_temp->st_mtime);
+ ve[10] = ulong2num((unsigned long)stat_temp->st_ctime);
+ return ans;
+}
+# ifdef __TURBOC__
+# include <process.h>
+# endif
+SCM l_getpid()
+{
+ return MAKINUM((unsigned long)getpid());
+}
+# endif /* MCH_AMIGA */
+#endif /* THINK_C */
+
+#ifndef __IBMC__
+# ifndef THINK_C
+# ifndef __WATCOMC__
+# ifndef GO32
+# ifndef _Windows
+# ifdef __TURBOC__
+# include <process.h>
+# endif
+char s_execv[] = "execv";
+char s_execvp[] = "execvp";
+SCM i_execv(modes, path, args)
+ char * modes;
+ SCM path, args;
+{
+ char **execargv;
+ int i = ilength(args);
+ ASSERT(i>0, args, WNA, s_execv);
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_execv);
+ /* dowinds(EOL, ilength(dynwinds)); */
+ args = cons(path, args);
+ DEFER_INTS;
+ execargv = makargvfrmstrs(args, s_execv);
+ ALLOW_INTS;
+ (strchr(modes, 'p') ? execvp : execv)(execargv[0], &execargv[1]);
+ perror(execargv[0]);
+ return MAKINUM(errno);
+}
+SCM lexec(path, arg0, args)
+ SCM path, arg0, args;
+{
+ return i_execv("", path, cons(arg0, args));
+}
+SCM lexecp(path, arg0, args)
+ SCM path, arg0, args;
+{
+ return i_execv("p", path, cons(arg0, args));
+}
+SCM lexecv(path, args)
+ SCM path, args;
+{
+ return i_execv("", path, args);
+}
+SCM lexecvp(path, args)
+ SCM path, args;
+{
+ return i_execv("p", path, args);
+}
+static char s_putenv[] = "putenv";
+SCM l_putenv(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_putenv);
+ return putenv(CHARS(str)) ? BOOL_F : BOOL_T;
+}
+# endif
+# endif
+# endif
+# endif
+#endif
+
+static iproc subr1s[] = {
+ {s_file_position, file_position},
+ {s_fileno, l_fileno},
+ {s_isatty, l_isatty},
+#ifndef MCH_AMIGA
+# ifndef vms
+# ifndef _WIN32
+ {s_opendir, l_opendir},
+ {s_readdir, l_readdir},
+ {s_rewinddir, l_rewinddir},
+ {s_closedir, l_closedir},
+# endif
+# endif
+ {s_rmdir, l_rmdir},
+#endif
+#ifndef THINK_C
+# ifndef MCH_AMIGA
+ {s_umask, l_umask},
+# endif
+ {s_chdir, lchdir},
+ {s_stat, l_stat},
+#endif
+ {0, 0}};
+
+static iproc subr1os[] = {
+ {s_read_line, read_line},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_ren_fil, ren_fil},
+ {s_access, l_access},
+#ifndef MCH_AMIGA
+ {s_dup, l_dup},
+ {s_dup2, l_dup2},
+ {s_mkdir, l_mkdir},
+# ifndef THINK_C
+ {s_chmod, l_chmod},
+# endif
+#endif
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_file_set_pos, file_set_position},
+ {s_read_line1, read_line1},
+ {s_write_line, l_write_line},
+ {0, 0}};
+
+void init_ioext()
+{
+ init_iprocs(subr1os, tc7_subr_1o);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(subr2s, tc7_subr_2);
+ make_subr(s_reopen_file, tc7_subr_3, reopen_file);
+#ifndef THINK_C
+# ifndef MCH_AMIGA
+ make_subr("getpid", tc7_subr_0, l_getpid);
+ make_subr("getcwd", tc7_subr_0, l_getcwd);
+# ifndef vms
+# ifndef _WIN32
+ make_subr(s_utime, tc7_subr_3, l_utime);
+ tc16_dir = newsmob(&dir_smob);
+# endif
+# endif
+# endif
+#endif
+#ifndef __IBMC__
+# ifndef THINK_C
+# ifndef __WATCOMC__
+# ifndef GO32
+# ifndef _Windows
+ make_subr(s_execv, tc7_subr_2, lexecv);
+ make_subr(s_execvp, tc7_subr_2, lexecvp);
+ make_subr("execl", tc7_lsubr_2, lexec);
+ make_subr("execlp", tc7_lsubr_2, lexecp);
+ make_subr(s_putenv, tc7_subr_1, l_putenv);
+# endif
+# endif
+# endif
+# endif
+#endif
+ add_feature("i/o-extensions");
+ add_feature("line-i/o");
+}
diff --git a/mkinstalldirs b/mkinstalldirs
new file mode 100755
index 0000000..0e29377
--- /dev/null
+++ b/mkinstalldirs
@@ -0,0 +1,35 @@
+#!/bin/sh
+# Make directory hierarchy.
+# Written by Noah Friedman <friedman@prep.ai.mit.edu>
+# Public domain.
+
+defaultIFS='
+'
+IFS="${IFS-${defaultIFS}}"
+
+errstatus=0
+
+for file in ${1+"$@"} ; do
+ oIFS="${IFS}"
+ # Some sh's can't handle IFS=/ for some reason.
+ IFS='%'
+ set - `echo ${file} | sed -e 's@/@%@g' -e 's@^%@/@'`
+ IFS="${oIFS}"
+
+ pathcomp=''
+
+ for d in ${1+"$@"} ; do
+ pathcomp="${pathcomp}${d}"
+
+ if test ! -d "${pathcomp}"; then
+ echo "mkdir $pathcomp" 1>&2
+ mkdir "${pathcomp}" || errstatus=$?
+ fi
+
+ pathcomp="${pathcomp}/"
+ done
+done
+
+exit $errstatus
+
+# eof
diff --git a/patchlvl.h b/patchlvl.h
new file mode 100644
index 0000000..97543ec
--- /dev/null
+++ b/patchlvl.h
@@ -0,0 +1,8 @@
+/* SCMVERSION is a string for the version specifier. The leading
+ number is the major version number, the letter is the revision ("a"
+ for alpha release, "b" for beta release, "c", and so on), and the
+ trailing number is the patchlevel. */
+
+#ifndef SCMVERSION
+# define SCMVERSION "4e6"
+#endif
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 <n> <d> prints out <n> digits of pi in groups of <d> digits.
+
+'Spigot' algorithm origionally due to Stanly Rabinowitz.
+This algorithm takes time proportional to the square of <n>/<d>.
+This fact can make comparisons of computational speed between systems
+of vastly differring performances quicker and more accurate.
+
+Try: pi 100 5
+The digit size <d> will have to be reduced for larger <n> or an
+error due to overflow will occur. */
+
+short *calloc();
+main(c,v)
+int c;char **v;{
+ int n=200,j=0,m,b=2,k=0,t,r=1,d=5;
+ long q;
+ short *a;
+ if(c>1)n=atoi(v[1]);
+ if(c>2)d=atoi(v[2]);
+ while(k++<d)r=r*10;
+ n=n/d+1;
+ k=m=3.322*n*d;
+ a=calloc(1+m,2);
+ while(k)a[--k]=2;
+ for(a[m]=4;j<n;b=q%r){
+ q=0;
+ for(k=m;k;){
+ q+=a[k]*r;
+ t=(2*k+1);
+ a[k]=q%t;
+ q=q/t;
+ q*=k--;}
+ printf("%0*d%s",d,b+q/r,++j%10?" ":"\n");}
+ puts("");}
diff --git a/pi.scm b/pi.scm
new file mode 100644
index 0000000..bb533bc
--- /dev/null
+++ b/pi.scm
@@ -0,0 +1,165 @@
+;; Copyright (C) 1991, 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "pi.scm", program for computing digits of numerical value of PI.
+;;;; "bigpi.scm", program for computing digits of numerical value of PI.
+;;;; "e.scm", program for computing digits of numerical value of 'e'.
+;;; Authors: Aubrey Jaffer & Jerry D. Hedden
+
+;;; (pi <n> <d>) prints out <n> digits of pi in groups of <d> digits.
+
+;;; 'Spigot' algorithm origionally due to Stanly Rabinowitz.
+;;; This algorithm takes time proportional to the square of <n>/<d>.
+;;; This fact can make comparisons of computational speed between systems
+;;; of vastly differring performances quicker and more accurate.
+
+;;; Try (pi 100 5)
+;;; The digit size <d> will have to be reduced for larger <n> or an
+;;; overflow error will occur (on systems lacking bignums).
+
+;;; It your Scheme has bignums try (pi 1000).
+
+(define (pi n . args)
+ (if (null? args) (bigpi n)
+ (let* ((d (car args))
+ (r (do ((s 1 (* 10 s))
+ (i d (- i 1)))
+ ((zero? i) s)))
+ (n (+ (quotient n d) 1))
+ (m (quotient (* n d 3322) 1000))
+ (a (make-vector (+ 1 m) 2)))
+ (vector-set! a m 4)
+ (do ((j 1 (+ 1 j))
+ (q 0 0)
+ (b 2 (remainder q r)))
+ ((> j n))
+ (do ((k m (- k 1)))
+ ((zero? k))
+ (set! q (+ q (* (vector-ref a k) r)))
+ (let ((t (+ 1 (* 2 k))))
+ (vector-set! a k (remainder q t))
+ (set! q (* k (quotient q t)))))
+ (let ((s (number->string (+ b (quotient q r)))))
+ (do ((l (string-length s) (+ 1 l)))
+ ((>= l d) (display s))
+ (display #\0)))
+ (if (zero? (modulo j 10)) (newline) (display #\ )))
+ (newline))))
+
+;;; (pi <n>) prints out <n> digits of pi.
+
+;;; 'Spigot' algorithm originally due to Stanly Rabinowitz:
+;;;
+;;; PI = 2+(1/3)*(2+(2/5)*(2+(3/7)*(2+ ... *(2+(k/(2k+1))*(4)) ... )))
+;;;
+;;; where 'k' is approximately equal to the desired precision of 'n'
+;;; places times 'log2(10)'.
+;;;
+;;; This version takes advantage of "bignums" in SCM to compute all
+;;; of the requested digits in one pass! Basically, it calculates
+;;; the truncated portion of (PI * 10^n), and then displays it in a
+;;; nice format.
+
+(define (bigpi digits)
+ (let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10
+ (z (inexact->exact (truncate ; z = number of terms
+ (/ (* n (log 10)) (log 2)))))
+ (q (do ((x 2 (* 10000000000 x)) ; q = 2 * 10^n
+ (i (/ n 10) (- i 1)))
+ ((zero? i) x)))
+ (_pi (number->string ; _pi = PI * 10^n
+ ;; do the calculations in one pass!!!
+ (let pi_calc ((j z) (k (+ z z 1)) (p (+ q q)))
+ (if (zero? j)
+ p
+ (pi_calc (- j 1) (- k 2) (+ q (quotient (* p j) k))))))))
+ ;; print out the result ("3." followed by 5 groups of 10 digits per line)
+ (display (substring _pi 0 1)) (display #\.) (newline)
+ (do ((i 0 (+ i 10)))
+ ((>= i n))
+ (display (substring _pi (+ i 1) (+ i 11)))
+ (display (if (zero? (modulo (+ i 10) 50)) #\newline #\ )))
+ (if (not (zero? (modulo n 50))) (newline))))
+
+;;; (e <n>) prints out <n> digits of 'e'.
+
+;;; Uses the formula:
+;;;
+;;; 1 1 1 1 1
+;;; e = 1 + -- + -- + -- + -- + ... + --
+;;; 1! 2! 3! 4! k!
+;;;
+;;; where 'k' is determined using the desired precision 'n' in:
+;;;
+;;; n < ((k * (ln(k) - 1)) / ln(10))
+;;;
+;;; which uses Stirling's formula for approximating ln(k!)
+;;;
+;;; This program takes advantage of "bignums" in SCM to compute all
+;;; the requested digits at once! Basically, it calculates the
+;;; fractional part of 'e' (i.e., e-2) as a fraction of two bignums
+;;; 'e_n' and 'e_d', determines the integer part of (e_n * 10^n)/e_d,
+;;; and then displays it in a nice format.
+
+(define (e digits)
+ (let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10
+ (k (do ((i 15 (+ i 1))) ; k = number of terms
+ ((< n (/ (* i (- (log i) 1)) (log 10))) i)))
+ (q (do ((x 1 (* 10000000000 x)) ; q = 10^n
+ (i (/ n 10) (- i 1)))
+ ((zero? i) x)))
+ (_e (let ((ee
+ ; do calculations
+ (let e_calc ((i k) (e_d 1) (e_n 0))
+ (if (= i 1)
+ (cons (* q e_n) e_d)
+ (e_calc (- i 1) (* e_d i) (+ e_n e_d))))))
+ (number->string (+ (quotient (car ee) (cdr ee))
+ ; rounding
+ (if (< (remainder (car ee) (cdr ee))
+ (quotient (cdr ee) 2))
+ 0 1))))))
+ ;; print out the result ("2." followed by 5 groups of 10 digits per line)
+ (display "2.") (newline)
+ (do ((i 0 (+ i 10)))
+ ((>= i n))
+ (display (substring _e i (+ i 10)))
+ (display (if (zero? (modulo (+ i 10) 50)) #\newline #\ )))
+ (if (not (zero? (modulo n 50))) (newline))))
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 <pwd.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#ifndef STDC_HEADERS
+ char *ttyname P((int fd));
+ FILE *popen P((const char* command, const char* type));
+ int pclose P((FILE* stream));
+#endif
+
+ /* Only the superuser can successfully execute this call */
+static char s_chown[] = "chown";
+SCM l_chown(path, owner, group)
+ SCM path, owner, group;
+{
+ int val;
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_chown);
+ ASSERT(INUMP(owner), owner, ARG2, s_chown);
+ ASSERT(INUMP(group), group, ARG3, s_chown);
+ SYSCALL(val = chown(CHARS(path), INUM(owner), INUM(group)););
+ return val ? BOOL_F : BOOL_T;
+}
+
+static char s_link[] = "link";
+SCM l_link(oldpath, newpath)
+ SCM oldpath, newpath;
+{
+ int val;
+ ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_link);
+ ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_link);
+ SYSCALL(val = link(CHARS(oldpath), CHARS(newpath)););
+ return val ? BOOL_F : BOOL_T;
+}
+
+SCM l_pipe()
+{
+ int fd[2], ret;
+ FILE *f_rd, *f_wt;
+ SCM p_rd, p_wt;
+ NEWCELL(p_rd); NEWCELL(p_wt);
+ SYSCALL(ret = pipe(fd););
+ if (ret) {ALLOW_INTS; return BOOL_F;}
+ SYSCALL(f_rd = fdopen(fd[0], "r"););
+ if (!f_rd) {
+ close(fd[0]);
+ goto errout;
+ }
+ SYSCALL(f_wt = fdopen(fd[1], "w"););
+ if (!f_wt) {
+ fclose(f_rd);
+ errout:
+ close(fd[1]);
+ wta(UNDEFINED, (char *)NALLOC, s_port_type);
+ }
+ CAR(p_rd) = tc16_fport | mode_bits("r");
+ CAR(p_wt) = tc16_fport | mode_bits("w");
+ SETSTREAM(p_rd, f_rd);
+ SETSTREAM(p_wt, f_wt);
+ ALLOW_INTS;
+ return cons(p_rd, p_wt);
+}
+
+char s_op_pipe[] = "open-pipe";
+SCM open_pipe(pipestr, modes)
+ SCM pipestr, modes;
+{
+ FILE *f;
+ register SCM z;
+ ASSERT(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe);
+ ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_op_pipe);
+ NEWCELL(z);
+ /* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/
+ DEFER_INTS;
+ ignore_signals();
+ SYSCALL(f = popen(CHARS(pipestr), CHARS(modes)););
+ unignore_signals();
+ if (!f) z = BOOL_F;
+ else {
+ CAR(z) = tc16_pipe | OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG);
+ SETSTREAM(z, f);
+ }
+ ALLOW_INTS;
+ return z;
+}
+SCM l_open_input_pipe(pipestr)
+ SCM pipestr;
+{
+ return open_pipe(pipestr, makfromstr("r", (sizeof "r")-1));
+}
+SCM l_open_output_pipe(pipestr)
+ SCM pipestr;
+{
+ return open_pipe(pipestr, makfromstr("w", (sizeof "w")-1));
+}
+static int prinpipe(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ prinport(exp, port, s_pipe);
+ return !0;
+}
+
+static char scm_s_getgroups[] = "getgroups";
+SCM scm_getgroups()
+{
+ SCM grps, ans;
+ int ngroups = getgroups(NULL, 0);
+ if (!ngroups) return BOOL_F;
+ NEWCELL(grps);
+ DEFER_INTS;
+ {
+ gid_t *groups = (gid_t *)must_malloc(ngroups * sizeof(gid_t),
+ scm_s_getgroups);
+ int val = getgroups(ngroups, groups);
+ if (val < 0) {
+ must_free(groups);
+ ALLOW_INTS;
+ return BOOL_F;
+ }
+ SETCHARS(grps, groups); /* set up grps as a GC protect */
+ SETLENGTH(grps, 0L + ngroups * sizeof(gid_t), tc7_string);
+ ALLOW_INTS;
+ ans = make_vector(MAKINUM(ngroups), UNDEFINED);
+ while (--ngroups >= 0) VELTS(ans)[ngroups] = MAKINUM(groups[ngroups]);
+ SETCHARS(grps, groups); /* to make sure grps stays around. */
+ return ans;
+ }
+}
+
+/* These 2 routines are not protected against `entry' being reused
+ before access to that structure is completed */
+
+static char s_pwinfo[] = "getpw";
+SCM l_pwinfo(user)
+ SCM user;
+{
+ SCM ans = make_vector(MAKINUM(7), UNSPECIFIED);
+ struct passwd *entry;
+ SCM *ve = VELTS(ans);
+ DEFER_INTS;
+ if UNBNDP(user) SYSCALL(entry = getpwent(););
+ else if INUMP(user) SYSCALL(entry = getpwuid(INUM(user)););
+ else {
+ ASSERT(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo);
+ SYSCALL(entry = getpwnam(CHARS(user)););
+ }
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->pw_name);
+ ve[ 1] = makfrom0str(entry->pw_passwd);
+ ve[ 2] = ulong2num((unsigned long)entry->pw_uid);
+ ve[ 3] = ulong2num((unsigned long)entry->pw_gid);
+ ve[ 4] = makfrom0str(entry->pw_gecos);
+ ve[ 5] = makfrom0str(entry->pw_dir);
+ ve[ 6] = makfrom0str(entry->pw_shell);
+ return ans;
+}
+#include <grp.h>
+static char s_grinfo[] = "getgr";
+SCM l_grinfo(name)
+ SCM name;
+{
+ SCM ans = make_vector(MAKINUM(4), UNSPECIFIED);
+ struct group *entry;
+ SCM *ve = VELTS(ans);
+ DEFER_INTS;
+ if UNBNDP(name) SYSCALL(entry = getgrent(););
+ else if INUMP(name) SYSCALL(entry = getgrgid(INUM(name)););
+ else {
+ ASSERT(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo);
+ SYSCALL(entry = getgrnam(CHARS(name)););
+ }
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->gr_name);
+ ve[ 1] = makfrom0str(entry->gr_passwd);
+ ve[ 2] = ulong2num((unsigned long)entry->gr_gid);
+ ve[ 3] = makfromstrs(-1, entry->gr_mem);
+ return ans;
+}
+SCM l_setgr(arg)
+ SCM arg;
+{
+ if (UNBNDP(arg) || FALSEP(arg)) endgrent();
+ else setgrent();
+ return UNSPECIFIED;
+}
+SCM l_setpw(arg)
+ SCM arg;
+{
+ if (UNBNDP(arg) || FALSEP(arg)) endpwent();
+ else setpwent();
+ return UNSPECIFIED;
+}
+
+static char s_kill[] = "kill";
+SCM l_kill(pid, sig)
+ SCM pid, sig;
+{
+ int i;
+ ASSERT(INUMP(pid), pid, ARG1, s_kill);
+ ASSERT(INUMP(sig), sig, ARG2, s_kill);
+ SYSCALL(i = kill((int)INUM(pid), (int)INUM(sig)););
+ return MAKINUM(0L+i);
+}
+static char s_waitpid[] = "waitpid";
+SCM l_waitpid(pid, options)
+ SCM pid, options;
+{
+ int i, status;
+ ASSERT(INUMP(pid), pid, ARG1, s_waitpid);
+ ASSERT(INUMP(options), options, ARG2, s_waitpid);
+ SYSCALL(i = waitpid(INUM(pid), &status, INUM(options)););
+ return i < 0 ? BOOL_F : MAKINUM(0L+status);
+}
+
+SCM l_getppid()
+{
+ return MAKINUM(0L+getppid());
+}
+
+SCM l_getuid()
+{
+ return MAKINUM(0L+getuid());
+}
+SCM l_getgid()
+{
+ return MAKINUM(0L+getgid());
+}
+#ifndef LACK_E_IDs
+SCM l_geteuid()
+{
+ return MAKINUM(0L+geteuid());
+}
+SCM l_getegid()
+{
+ return MAKINUM(0L+getegid());
+}
+#endif
+
+static char s_setuid[] = "setuid";
+SCM l_setuid(id)
+ SCM id;
+{
+ ASSERT(INUMP(id), id, ARG1, s_setuid);
+ return setuid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+static char s_setgid[] = "setgid";
+SCM l_setgid(id)
+ SCM id;
+{
+ ASSERT(INUMP(id), id, ARG1, s_setgid);
+ return setgid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+
+#ifndef LACK_E_IDs
+static char s_seteuid[] = "seteuid";
+SCM l_seteuid(id)
+ SCM id;
+{
+ ASSERT(INUMP(id), id, ARG1, s_seteuid);
+ return seteuid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+static char s_setegid[] = "setegid";
+SCM l_setegid(id)
+ SCM id;
+{
+ ASSERT(INUMP(id), id, ARG1, s_setegid);
+ return setegid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+#endif
+
+static char s_ttyname[] = "ttyname";
+SCM l_ttyname(port)
+ SCM port;
+{
+ char *ans;
+ ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_ttyname);
+ if (tc16_fport != TYP16(port)) return BOOL_F;
+ SYSCALL(ans = ttyname(fileno(STREAM(port))););
+ /* ans could be overwritten by another call to ttyname */
+ return ans ? makfrom0str(ans) : BOOL_F;
+}
+
+SCM l_fork()
+{
+ long pid = 0L + fork();
+ return -1L==pid ? BOOL_F : MAKINUM(pid);
+}
+
+#include <sys/utsname.h>
+SCM l_uname()
+{
+ struct utsname buf;
+ SCM ans = make_vector(MAKINUM(5), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ if (uname(&buf)) return BOOL_F;
+ ve[ 0] = makfrom0str(buf.sysname);
+ ve[ 1] = makfrom0str(buf.nodename);
+ ve[ 2] = makfrom0str(buf.release);
+ ve[ 3] = makfrom0str(buf.version);
+ ve[ 4] = makfrom0str(buf.machine);
+ /* ve[ 5] = makfrom0str(buf.domainname); */
+ return ans;
+}
+
+static iproc subr0s[] = {
+ {"pipe", l_pipe},
+ {scm_s_getgroups, scm_getgroups},
+ {"getppid", l_getppid},
+ {"getuid", l_getuid},
+ {"getgid", l_getgid},
+#ifndef LACK_E_IDs
+ {"getegid", l_getegid},
+ {"geteuid", l_geteuid},
+#endif
+ {"uname", l_uname},
+ {"fork", l_fork},
+ {0, 0}};
+
+static iproc subr1os[] = {
+ {s_pwinfo, l_pwinfo},
+ {s_grinfo, l_grinfo},
+ {"setpwent", l_setpw},
+ {"setgrent", l_setgr},
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {"setuid", l_setuid},
+ {"setgid", l_setgid},
+#ifndef LACK_E_IDs
+ {"setegid", l_setegid},
+ {"seteuid", l_seteuid},
+#endif
+ {"open-input-pipe", l_open_input_pipe},
+ {"open-output-pipe", l_open_output_pipe},
+ {s_ttyname, l_ttyname},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_link, l_link},
+ {s_kill, l_kill},
+ {s_waitpid, l_waitpid},
+ {s_op_pipe, open_pipe},
+ {0, 0}};
+
+static iproc subr3s[] = {
+ {s_chown, l_chown},
+ {0, 0}};
+
+void init_posix()
+{
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr1os, tc7_subr_1o);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(subr3s, tc7_subr_3);
+ add_feature("posix");
+ ptobs[0x0ff & (tc16_pipe>>8)].fclose = pclose;
+ ptobs[0x0ff & (tc16_pipe>>8)].free = pclose;
+ ptobs[0x0ff & (tc16_pipe>>8)].print = prinpipe;
+ add_feature(s_pipe);
+}
diff --git a/pre-crt0.c b/pre-crt0.c
new file mode 100644
index 0000000..67fd31c
--- /dev/null
+++ b/pre-crt0.c
@@ -0,0 +1,9 @@
+/* This file is loaded before crt0.o on machines where we do not
+ remap part of the data space into text space in unexec.
+ On these machines, there is no problem with standard crt0.o's
+ that make environ an initialized variable. However, we do
+ need to make sure the label data_start exists anyway. */
+
+/* Create a label to appear at the beginning of data space. */
+
+int data_start = 0;
diff --git a/r4rstest.scm b/r4rstest.scm
new file mode 100644
index 0000000..6573e20
--- /dev/null
+++ b/r4rstest.scm
@@ -0,0 +1,1038 @@
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation; either version 2, or (at your option) any
+;; later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; To receive a copy of the GNU General Public License, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA; or view
+;; http://www-swiss.ai.mit.edu/~jaffer/GPL.html
+
+;;;; "r4rstest.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named "r4rstest.scm".
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "r4rstest.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(set! i 0)
+(define j 0)
+(for-each (lambda (x y)
+ (set! j (+ 1 j))
+ (set! i 0)
+ (for-each (lambda (f)
+ (set! i (+ 1 i))
+ (cond ((and (= i j))
+ (cond ((not (f x))) (test #t f x)))
+ ((f x) (test #f f x)))
+ (cond ((and (= i j))
+ (cond ((not (f y))) (test #t f y)))
+ ((f y) (test #f f y))))
+ disjoint-type-functions))
+ (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
+ (list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(define old-+ +)
+(define + (lambda (x y) (list y x)))
+(test '(3 6) add3 6)
+(set! + old-+)
+(test 9 add3 6)
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+;(test #t boolean? #f)
+;(test #f boolean? 0)
+;(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+;(test #t pair? '(a . b))
+;(test #t pair? '(a . 1))
+;(test #t pair? '(a b c))
+;(test #f pair? '())
+;(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+;(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+;(test #f symbol? "bar")
+;(test #t symbol? 'nil)
+;(test #f symbol? '())
+;(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+(test #t 'standard-case
+ (string=? (symbol->string 'a) (symbol->string 'A)))
+(test #t 'standard-case
+ (or (string=? (symbol->string 'a) "A")
+ (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+(test #t eq? 'mISSISSIppi 'mississippi)
+(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'inexact? (inexact? (max f3.9 4)))
+ (test f4.0 'max (max f3.9 4))
+ (test f4.0 'exact->inexact (exact->inexact 4))
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test 0 modulo 3333333333 3)
+ (test 0 modulo 3333333333 -3)
+ (test 0 remainder 3333333333 3)
+ (test 0 remainder 3333333333 -3)
+ (test 2 modulo 3333333332 3)
+ (test -1 modulo 3333333332 -3)
+ (test 2 remainder 3333333332 3)
+ (test 2 remainder 3333333332 -3)
+ (test 1 modulo -3333333332 3)
+ (test -2 modulo -3333333332 -3)
+ (test -2 remainder -3333333332 3)
+ (test -2 remainder -3333333332 -3)
+
+ (test 3 modulo 3 3333333333)
+ (test 3333333330 modulo -3 3333333333)
+ (test 3 remainder 3 3333333333)
+ (test -3 remainder -3 3333333333)
+ (test -3333333330 modulo 3 -3333333333)
+ (test -3 modulo -3 -3333333333)
+ (test 3 remainder 3 -3333333333)
+ (test -3 remainder -3 -3333333333)
+
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+;(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+;(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+;(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "r4rstest.scm" input-port?)
+(define this-file (open-input-file "r4rstest.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(newline)
+(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
+(newline)
+(display "(test-cont) (test-sc4) (test-delay)")
+(newline)
+"last item in file"
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<<n)) | (*sv & ~(~0L<<n));
+ }
+ else {
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ if (VELTS(src)[i_s/LONG_BIT] & (1L << (i_s%LONG_BIT)))
+ VELTS(dst)[i_d/LONG_BIT] |= (1L << (i_d%LONG_BIT));
+ else
+ VELTS(dst)[i_d/LONG_BIT] &= ~(1L << (i_d%LONG_BIT));
+ }
+ break;
+ case tc7_uvect:
+ case tc7_ivect: {
+ long *d = (long *)VELTS(dst), *s = (long *)VELTS(src);
+ if (TYP7(src)==TYP7(dst)) {
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ }
+ else if (tc7_ivect==TYP7(dst))
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = num2long(cvref(src, i_s, UNDEFINED),
+ (char *)ARG2, s_array_copy);
+ else
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = num2ulong(cvref(src, i_s, UNDEFINED),
+ (char *)ARG2, s_array_copy);
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *d = (float *)VELTS(dst);
+ float *s = (float *)VELTS(src);
+ switch TYP7(src) {
+ default: goto gencase;
+ case tc7_ivect: case tc7_uvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((long *)s)[i_s]; )
+ break;
+ case tc7_fvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s]; )
+ break;
+ case tc7_dvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((double *)s)[i_s]; )
+ break;
+ }
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *d = (double *)VELTS(dst);
+ double *s = (double *)VELTS(src);
+ switch TYP7(src) {
+ default: goto gencase;
+ case tc7_ivect: case tc7_uvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((long *)s)[i_s]; )
+ break;
+ case tc7_fvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((float *)s)[i_s];)
+ break;
+ case tc7_dvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];)
+ break;
+ }
+ break;
+ }
+ case tc7_cvect: {
+ double (*d)[2] = (double (*)[2])VELTS(dst);
+ double (*s)[2] = (double (*)[2])VELTS(src);
+ switch TYP7(src) {
+ default: goto gencase;
+ case tc7_ivect: case tc7_uvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+ d[i_d][0] = ((long *)s)[i_s];
+ d[i_d][1] = 0.0;
+ })
+ break;
+ case tc7_fvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+ d[i_d][0] = ((float *)s)[i_s];
+ d[i_d][1] = 0.0;
+ })
+ break;
+ case tc7_dvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+ d[i_d][0] = ((double *)s)[i_s];
+ d[i_d][1] = 0.0;
+ })
+ break;
+ case tc7_cvect:
+ IVDEP(src != dst,
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
+ d[i_d][0] = s[i_s][0];
+ d[i_d][1] = s[i_s][1];
+ })
+ }
+ break;
+ }
+# endif /* FLOATS */
+ }
+ return 1;
+}
+SCM array_copy(src, dst)
+ SCM src;
+ SCM dst;
+{
+#ifndef RECKLESS
+ if (INUM0==array_rank(dst))
+ ASSERT(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
+ dst, ARG2, s_array_copy);
+#endif
+ ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy);
+ return UNSPECIFIED;
+}
+
+SCM ra2contig(ra, copy)
+ SCM ra;
+ int copy;
+{
+ SCM ret;
+ long inc = 1;
+ sizet k, len = 1;
+ for (k = ARRAY_NDIM(ra); k--;)
+ len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
+ k = ARRAY_NDIM(ra);
+ if (ARRAY_CONTP(ra) && ((0==k) || (1==ARRAY_DIMS(ra)[k-1].inc))) {
+ if (tc7_bvect != TYP7(ARRAY_V(ra)))
+ return ra;
+ if ((len==LENGTH(ARRAY_V(ra)) &&
+ 0==ARRAY_BASE(ra) % LONG_BIT &&
+ 0==len % LONG_BIT))
+ return ra;
+ }
+ ret = make_ra(k);
+ ARRAY_BASE(ret) = 0;
+ while (k--) {
+ ARRAY_DIMS(ret)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
+ ARRAY_DIMS(ret)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
+ ARRAY_DIMS(ret)[k].inc = inc;
+ inc *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
+ }
+ CAR(ret) |= ARRAY_CONTIGUOUS;
+ ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra));
+ if (copy) array_copy(ra, ret);
+ return ret;
+}
+
+static char s_ura_rd[] = "uniform-array-read!";
+SCM ura_read(ra, port)
+ SCM ra, port;
+{
+ SCM ret, cra;
+ if (NIMP(ra) && ARRAYP(ra)) {
+ cra = ra2contig(ra, 0);
+ ret = uve_read(cra, port);
+ if (cra != ra) array_copy(cra, ra);
+ return ret;
+ }
+ else return uve_read(ra, port);
+}
+
+static char s_ura_wr[] = "uniform-array-write";
+SCM ura_write(ra, port)
+ SCM ra, port;
+{
+ if (NIMP(ra) && ARRAYP(ra))
+ return uve_write(ra2contig(ra,1), port);
+ else
+ return uve_write(ra, port);
+}
+
+static char s_sc2array[] = "scalar->array";
+SCM sc2array(s, ra, prot)
+ SCM s, ra, prot;
+{
+ SCM res;
+ ASSERT(NIMP(ra), ra, ARG2, s_sc2array);
+ if ARRAYP(ra) {
+ int k = ARRAY_NDIM(ra);
+ res = make_ra(k);
+ while (k--) {
+ ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
+ ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
+ ARRAY_DIMS(res)[k].inc = 0;
+ }
+ ra = ARRAY_V(ra);
+ }
+ else {
+ ASSERT(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
+ res = make_ra(1);
+ ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1;
+ ARRAY_DIMS(res)->lbnd = 0;
+ ARRAY_DIMS(res)->inc = 0;
+ }
+ if (NIMP(s) && ARRAYP(s) && 0==ARRAY_NDIM(s)) {
+ ARRAY_BASE(res) = ARRAY_BASE(s);
+ ARRAY_V(res) = ARRAY_V(s);
+ return res;
+ }
+ ARRAY_BASE(res) = 0;
+ ARRAY_V(res) = make_uve(1L, NULLP(prot) ? array_prot(ra) : CAR(prot));
+ switch TYP7(ARRAY_V(res)) {
+ case tc7_vector:
+ break;
+ case tc7_string:
+ if ICHRP(s) break;
+ goto mismatch;
+ case tc7_uvect:
+ if (INUMP(s) && INUM(s)>=0) break;
+#ifdef BIGDIG
+ if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break;
+#endif
+ goto mismatch;
+ case tc7_ivect:
+ if INUMP(s) break;
+#ifdef BIGDIG
+ if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break;
+#endif
+ goto mismatch;
+#ifdef FLOATS
+#ifdef SINGLES
+ case tc7_fvect:
+#endif
+ case tc7_dvect:
+ if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break;
+ goto mismatch;
+ case tc7_cvect:
+ if NUMBERP(s) break;
+ goto mismatch;
+#endif
+ mismatch: ARRAY_V(res) = make_vector(MAKINUM(1), s);
+ return res;
+ }
+ aset(ARRAY_V(res), s, INUM0);
+ return res;
+}
+
+/* Functions callable by ARRAY-MAP! */
+int ra_eqp(ra0, ras)
+ SCM ra0, ras;
+{
+ SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ long inc2 = ARRAY_DIMS(ra2)->inc;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ ra2 = ARRAY_V(ra2);
+ switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
+ default: {
+ SCM e1 = UNDEFINED, e2 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))
+ BVE_CLR(ra0, i0);
+ break;
+ }
+ case tc7_uvect:
+ case tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0);
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2])
+ BVE_CLR(ra0, i0);
+ break;
+# endif /*SINGLES*/
+ case tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2])
+ BVE_CLR(ra0, i0);
+ break;
+ case tc7_cvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] ||
+ ((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1])
+ BVE_CLR(ra0, i0);
+ break;
+# endif /*FLOATS*/
+ }
+ return 1;
+}
+/* opt 0 means <, nonzero means >= */
+static int ra_compare(ra0, ra1, ra2, opt)
+ SCM ra0, ra1, ra2;
+ int opt;
+{
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ long inc2 = ARRAY_DIMS(ra2)->inc;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ ra2 = ARRAY_V(ra2);
+ switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
+ default: {
+ SCM e1 = UNDEFINED, e2 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (opt ?
+ NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) :
+ FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) )
+ BVE_CLR(ra0, i0);
+ break;
+ }
+ case tc7_uvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
+ if BVE_REF(ra0, i0)
+ if (opt ?
+ ((unsigned long*)VELTS(ra1))[i1] < ((unsigned long*)VELTS(ra2))[i2] :
+ ((unsigned long*)VELTS(ra1))[i1] >= ((unsigned long*)VELTS(ra2))[i2])
+ BVE_CLR(ra0, i0);
+ }
+ break;
+ case tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
+ if BVE_REF(ra0, i0)
+ if (opt ?
+ VELTS(ra1)[i1] < VELTS(ra2)[i2] :
+ VELTS(ra1)[i1] >= VELTS(ra2)[i2])
+ BVE_CLR(ra0, i0);
+ }
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (opt ?
+ ((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] :
+ ((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2])
+ BVE_CLR(ra0, i0);
+ break;
+# endif /*SINGLES*/
+ case tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if (opt ?
+ ((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] :
+ ((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2])
+ BVE_CLR(ra0, i0);
+ break;
+# endif /*FLOATS*/
+ }
+ return 1;
+}
+int ra_lessp(ra0, ras)
+ SCM ra0, ras;
+{
+ return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 0);
+}
+int ra_leqp(ra0, ras)
+ SCM ra0, ras;
+{
+ return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 1);
+}
+int ra_grp(ra0, ras)
+ SCM ra0, ras;
+{
+ return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 0);
+}
+int ra_greqp(ra0, ras)
+ SCM ra0, ras;
+{
+ return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 1);
+}
+
+int ra_sum(ra0, ras)
+ SCM ra0, ras;
+{
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ if NNULLP(ras) {
+ SCM ra1 = CAR(ras);
+ sizet i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+ ovflow: wta(ra0, (char *)OVFLOW, "+");
+ default: {
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, sum(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+ MAKINUM(i0));
+ break;
+ }
+ case tc7_uvect: {
+ unsigned long r;
+ unsigned long *v0 = (unsigned long *)VELTS(ra0);
+ unsigned long *v1 = (unsigned long *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] + v1[i1];
+ ASRTGO(r >= v0[i0], ovflow); /* Will prevent vectorization */
+ v0[i0] = r;
+ } );
+ break;
+ }
+ case tc7_ivect: {
+ long r, *v0 = (long *)VELTS(ra0), *v1 = (long *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] + v1[i1];
+ ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]<0 : r<=0 || v1[i1]>0), ovflow);
+ v0[i0] = r;
+ } );
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ float *v1 = (float *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] += v1[i1]);
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ double *v1 = (double *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] += v1[i1]);
+ break;
+ }
+ case tc7_cvect: {
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ double (*v1)[2] = (double (*)[2])VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ v0[i0][0] += v1[i1][0];
+ v0[i0][1] += v1[i1][1];
+ });
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ return 1;
+}
+
+int ra_difference(ra0, ras)
+ SCM ra0, ras;
+{
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ if NULLP(ras) {
+ switch TYP7(ra0) {
+ default: {
+ SCM e0 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ aset(ra0, difference(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+ break;
+ }
+ case tc7_ivect: {
+ long *v0 = VELTS(ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = -v0[i0];
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = -v0[i0];
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = -v0[i0];
+ break;
+ }
+ case tc7_cvect: {
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ for (; n-- > 0; i0 += inc0) {
+ v0[i0][0] = -v0[i0][0];
+ v0[i0][1] = -v0[i0][1];
+ }
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ else {
+ SCM ra1 = CAR(ras);
+ sizet i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+ ovflow: wta(ra0, (char *)OVFLOW, "-");
+ default: {
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, difference(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
+ break;
+ }
+ case tc7_uvect: {
+ unsigned long r;
+ unsigned long *v0 = (unsigned long *)VELTS(ra0);
+ unsigned long *v1 = (unsigned long*)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] - v1[i1];
+ ASRTGO(r <= v0[i0], ovflow);
+ v0[i0] = r;
+ } );
+ break;
+ }
+ case tc7_ivect: {
+ long r, *v0 = VELTS(ra0), *v1 = VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] - v1[i1];
+ ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]>0 : r<=0 || v1[i1]<0), ovflow);
+ v0[i0] = r;
+ } );
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ float *v1 = (float *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] -= v1[i1]);
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ double *v1 = (double *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] -= v1[i1]);
+ break;
+ }
+ case tc7_cvect: {
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ double (*v1)[2] = (double (*)[2])VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ v0[i0][0] -= v1[i1][0];
+ v0[i0][1] -= v1[i1][1];
+ })
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ return 1;
+}
+
+int ra_product(ra0, ras)
+ SCM ra0, ras;
+{
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ if NNULLP(ras) {
+ SCM ra1 = CAR(ras);
+ sizet i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+ ovflow: wta(ra0, (char *)OVFLOW, "*");
+ default: {
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, product(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+ MAKINUM(i0));
+ break;
+ }
+ case tc7_uvect: {
+ unsigned long r;
+ unsigned long *v0 = (unsigned long *)VELTS(ra0);
+ unsigned long *v1 = (unsigned long *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] * v1[i1];
+ ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
+ v0[i0] = r;
+ } );
+ break;
+ }
+ case tc7_ivect: {
+ long r, *v0 = VELTS(ra0), *v1 =VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0] * v1[i1];
+ ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
+ v0[i0] = r;
+ } );
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ float *v1 = (float *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] *= v1[i1]);
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ double *v1 = (double *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] *= v1[i1]);
+ break;
+ }
+ case tc7_cvect: {
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ register double r;
+ double (*v1)[2] = (double (*)[2])VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
+ v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
+ v0[i0][0] = r;
+ });
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ return 1;
+}
+int ra_divide(ra0, ras)
+ SCM ra0, ras;
+{
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ if NULLP(ras) {
+ switch TYP7(ra0) {
+ default: {
+ SCM e0 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ aset(ra0, divide(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = 1.0/v0[i0];
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ for (; n-- > 0; i0 += inc0)
+ v0[i0] = 1.0/v0[i0];
+ break;
+ }
+ case tc7_cvect: {
+ register double d;
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ for (; n-- > 0; i0 += inc0) {
+ d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
+ v0[i0][0] /= d;
+ v0[i0][1] /= -d;
+ }
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ else {
+ SCM ra1 = CAR(ras);
+ sizet i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
+ default: {
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, divide(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0);
+ float *v1 = (float *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] /= v1[i1]);
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0);
+ double *v1 = (double *)VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ v0[i0] /= v1[i1]);
+ break;
+ }
+ case tc7_cvect: {
+ register double d, r;
+ double (*v0)[2] = (double (*)[2])VELTS(ra0);
+ double (*v1)[2] = (double (*)[2])VELTS(ra1);
+ IVDEP(ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {
+ d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
+ r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
+ v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
+ v0[i0][0] = r;
+ })
+ break;
+ }
+# endif /* FLOATS */
+ }
+ }
+ return 1;
+}
+static int ra_identity(dst, src)
+ SCM src, dst;
+{
+ return racp(CAR(src), cons(dst, EOL));
+}
+
+static int ramap(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ long i = ARRAY_DIMS(ra0)->lbnd;
+ long inc = ARRAY_DIMS(ra0)->inc;
+ long n = ARRAY_DIMS(ra0)->ubnd;
+ long base = ARRAY_BASE(ra0) - i*inc;
+ ra0 = ARRAY_V(ra0);
+ if NULLP(ras)
+ for (; i <= n; i++)
+ aset(ra0, apply(proc, EOL, EOL), MAKINUM(i*inc + base));
+ else {
+ SCM ra1 = CAR(ras);
+ SCM args, *ve = &ras;
+ sizet k, i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ ras = CDR(ras);
+ if NULLP(ras)
+ ras = nullvect;
+ else {
+ ras = vector(ras);
+ ve = VELTS(ras);
+ }
+ for (; i <= n; i++, i1 += inc1) {
+ args = EOL;
+ for (k = LENGTH(ras); k--;)
+ args = cons(aref(ve[k], MAKINUM(i)), args);
+ args = cons(cvref(ra1, i1, UNDEFINED), args);
+ aset(ra0, apply(proc, args, EOL), MAKINUM(i*inc + base));
+ }
+ }
+ return 1;
+}
+static int ramap_cxr(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ SCM ra1 = CAR(ras);
+ SCM e1 = UNDEFINED;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+ long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra1)->lbnd + 1;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ switch TYP7(ra0) {
+ default: gencase:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, apply(proc, RVREF(ra1, i1, e1), listofnull), MAKINUM(i0));
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *dst = (float *)VELTS(ra0);
+ switch TYP7(ra1) {
+ default: goto gencase;
+ case tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = DSUBRF(proc)((double)((float *)VELTS(ra1))[i1]);
+ break;
+ case tc7_uvect:
+ case tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
+ break;
+ }
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *dst = (double *)VELTS(ra0);
+ switch TYP7(ra1) {
+ default: goto gencase;
+ case tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = DSUBRF(proc)(((double *)VELTS(ra1))[i1]);
+ break;
+ case tc7_uvect:
+ case tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
+ break;
+ }
+ break;
+ }
+# endif /* FLOATS */
+ }
+ return 1;
+}
+static int ramap_rp(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
+ SCM e1 = UNDEFINED, e2 = UNDEFINED;
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ long inc2 = ARRAY_DIMS(ra2)->inc;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ ra2 = ARRAY_V(ra2);
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if BVE_REF(ra0, i0)
+ if FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)))
+ BVE_CLR(ra0, i0);
+ return 1;
+}
+static int ramap_1(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ SCM ra1 = CAR(ras);
+ SCM e1 = UNDEFINED;
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+ long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ if (tc7_vector==TYP7(ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1)), MAKINUM(i0));
+ return 1;
+}
+static int ramap_2o(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ SCM ra1 = CAR(ras);
+ SCM e1 = UNDEFINED;
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
+ long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
+ ra0 = ARRAY_V(ra0);
+ ra1 = ARRAY_V(ra1);
+ ras = CDR(ras);
+ if NULLP(ras) {
+ if (tc7_vector==TYP7(ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED);
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1), UNDEFINED),
+ MAKINUM(i0));
+ }
+ else {
+ SCM ra2 = CAR(ras);
+ SCM e2 = UNDEFINED;
+ sizet i2 = ARRAY_BASE(ra2);
+ long inc2 = ARRAY_DIMS(ra2)->inc;
+ ra2 = ARRAY_V(ra2);
+ if (tc7_vector==TYP7(ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ VELTS(ra0)[i0] =
+ SUBRF(proc)(cvref(ra1, i1, UNDEFINED), cvref(ra2, i2, UNDEFINED));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ aset(ra0,
+ SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)),
+ MAKINUM(i0));
+ }
+ return 1;
+}
+static int ramap_a(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ if NULLP(ras)
+ for (; n-- > 0; i0 += inc0)
+ aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
+ else {
+ SCM ra1 = CAR(ras);
+ sizet i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
+ MAKINUM(i0));
+ }
+ return 1;
+}
+
+/* These tables are a kluge that will not scale well when more
+ vectorized subrs are added. It is tempting to steal some bits from
+ the CAR of all subrs (like those selected by SMOBNUM) to hold an
+ offset into a table of vectorized subrs. */
+
+static ra_iproc ra_rpsubrs[] = {
+ {"=", UNDEFINED, ra_eqp},
+ {"<", UNDEFINED, ra_lessp},
+ {"<=", UNDEFINED, ra_leqp},
+ {">", UNDEFINED, ra_grp},
+ {">=", UNDEFINED, ra_greqp},
+ {0, 0, 0}};
+static ra_iproc ra_asubrs[] = {
+ {"+", UNDEFINED, ra_sum},
+ {"-", UNDEFINED, ra_difference},
+ {"*", UNDEFINED, ra_product},
+ {"/", UNDEFINED, ra_divide},
+ {0, 0, 0}};
+
+static char s_sarray_map[] = "serial-array-map!";
+# define s_array_map (s_sarray_map + 7)
+SCM array_map(ra0, proc, lra)
+ SCM ra0, proc, lra;
+{
+ int narg = ilength(lra);
+ ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map);
+ tail:
+ switch TYP7(proc) {
+ wna: wta(UNDEFINED, (char *)WNA, s_array_map);
+ default: gencase:
+ ramapc(ramap, proc, ra0, lra, s_array_map);
+ return UNSPECIFIED;
+ case tc7_subr_1: ASRTGO(1==narg, wna);
+ ramapc(ramap_1, proc, ra0, lra, s_array_map);
+ return UNSPECIFIED;
+ case tc7_subr_2: ASRTGO(2==narg, wna);
+ case tc7_subr_2o: ASRTGO(2>=narg, wna);
+ ramapc(ramap_2o, proc, ra0, lra, s_array_map);
+ return UNSPECIFIED;
+ case tc7_cxr: if (! SUBRF(proc)) goto gencase;
+ ASRTGO(1==narg, wna);
+ ramapc(ramap_cxr, proc, ra0, lra, s_array_map);
+ return UNSPECIFIED;
+ case tc7_rpsubr: {
+ ra_iproc *p;
+ if (FALSEP(arrayp(ra0, BOOL_T))) goto gencase;
+ array_fill(ra0, BOOL_T);
+ for (p = ra_rpsubrs; p->name; p++)
+ if (proc==p->sproc) {
+ while (NNULLP(lra) && NNULLP(CDR(lra))) {
+ ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
+ lra = CDR(lra);
+ }
+ return UNSPECIFIED;
+ }
+ while (NNULLP(lra) && NNULLP(CDR(lra))) {
+ ramapc(ramap_rp, proc, ra0, lra, s_array_map);
+ lra = CDR(lra);
+ }
+ return UNSPECIFIED;
+ }
+ case tc7_asubr:
+ if NULLP(lra) {
+ SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED);
+ if INUMP(fill) {
+ prot = array_prot(ra0);
+# ifdef FLOATS
+ if (NIMP(prot) && INEXP(prot))
+ fill = makdbl((double)INUM(fill), 0.0);
+# endif
+ }
+ array_fill(ra0, fill);
+ }
+ else {
+ SCM tail, ra1 = CAR(lra);
+ SCM v0 = (NIMP(ra0) && ARRAYP(ra0) ? ARRAY_V(ra0) : ra0);
+ ra_iproc *p;
+ /* Check to see if order might matter.
+ This might be an argument for a separate
+ SERIAL-ARRAY-MAP! */
+ if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
+ if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0)))
+ goto gencase;
+ for (tail = CDR(lra); NNULLP(tail); tail = CDR(tail)) {
+ ra1 = CAR(tail);
+ if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
+ goto gencase;
+ }
+ for (p = ra_asubrs; p->name; p++)
+ if (proc==p->sproc) {
+ if (ra0 != CAR(lra))
+ ramapc(ra_identity, UNDEFINED, ra0, cons(CAR(lra), EOL), s_array_map);
+ lra = CDR(lra);
+ while (1) {
+ ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
+ if (IMP(lra) || IMP(CDR(lra))) return UNSPECIFIED;
+ lra = CDR(lra);
+ }
+ }
+ ramapc(ramap_2o, proc, ra0, lra, s_array_map);
+ lra = CDR(lra);
+ if NIMP(lra)
+ for (lra = CDR(lra); NIMP(lra); lra = CDR(lra))
+ ramapc(ramap_a, proc, ra0, lra, s_array_map);
+ }
+ return UNSPECIFIED;
+#ifdef CCLO
+ case tc7_cclo:
+ lra = cons(sc2array(proc,ra0,EOL), lra);
+ proc = CCLO_SUBR(proc);
+ goto tail;
+#endif
+ }
+}
+
+static int rafe(ra0, proc, ras)
+ SCM ra0, proc, ras;
+{
+ long i = ARRAY_DIMS(ra0)->lbnd;
+ sizet i0 = ARRAY_BASE(ra0);
+ long inc0 = ARRAY_DIMS(ra0)->inc;
+ long n = ARRAY_DIMS(ra0)->ubnd;
+ ra0 = ARRAY_V(ra0);
+ if NULLP(ras)
+ for (; i <= n; i++, i0 += inc0)
+ apply(proc, cvref(ra0, i0, UNDEFINED), listofnull);
+ else {
+ SCM ra1 = CAR(ras);
+ SCM args, *ve = &ras;
+ sizet k, i1 = ARRAY_BASE(ra1);
+ long inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ ras = CDR(ras);
+ if NULLP(ras)
+ ras = nullvect;
+ else {
+ ras = vector(ras);
+ ve = VELTS(ras);
+ }
+ for (; i <= n; i++, i0 += inc0, i1 += inc1) {
+ args = EOL;
+ for (k = LENGTH(ras); k--;)
+ args = cons(aref(ve[k], MAKINUM(i)), args);
+ args = cons2(cvref(ra0, i0, UNDEFINED), cvref(ra1, i1, UNDEFINED), args);
+ apply(proc, args, EOL);
+ }
+ }
+ return 1;
+}
+static char s_array_for_each[] = "array-for-each";
+SCM array_for_each(proc, ra0, lra)
+ SCM proc, ra0, lra;
+{
+ ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each);
+ tail:
+ switch TYP7(proc) {
+ default:
+ ramapc(rafe, proc, ra0, lra, s_array_for_each);
+ return UNSPECIFIED;
+#ifdef CCLO
+ case tc7_cclo:
+ lra = cons(ra0, lra);
+ ra0 = sc2array(proc, ra0, EOL);
+ proc = CCLO_SUBR(proc);
+ goto tail;
+#endif
+ }
+}
+
+static char s_array_imap[] = "array-index-map!";
+SCM array_imap(ra, proc)
+ SCM ra, proc;
+{
+ sizet i;
+ ASSERT(NIMP(ra), ra, ARG1, s_array_imap);
+ ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap);
+ switch TYP7(ra) {
+ default: badarg: wta(ra, (char *)ARG1, s_array_imap);
+ case tc7_vector:
+ {
+ SCM *ve = VELTS(ra);
+ for (i = 0; i < LENGTH(ra); i++)
+ ve[i] = apply(proc, MAKINUM(i), listofnull);
+ return UNSPECIFIED;
+ }
+ case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ for (i = 0; i < LENGTH(ra); i++)
+ aset(ra, apply(proc, MAKINUM(i), listofnull), MAKINUM(i));
+ return UNSPECIFIED;
+ case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
+ {
+ SCM args = EOL;
+ SCM inds = make_uve(ARRAY_NDIM(ra)+0L, MAKINUM(-1L));
+ long *vinds = VELTS(inds);
+ int j, k, kmax = ARRAY_NDIM(ra) - 1;
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = ARRAY_DIMS(ra)[k].lbnd;
+ k = kmax;
+ do {
+ if (k==kmax) {
+ vinds[k] = ARRAY_DIMS(ra)[k].lbnd;
+ i = cind(ra, inds);
+ for (; vinds[k] <= ARRAY_DIMS(ra)[k].ubnd; vinds[k]++) {
+ for (j = kmax+1, args = EOL; j--;)
+ args = cons(MAKINUM(vinds[j]), args);
+ aset(ARRAY_V(ra), apply(proc, args, EOL), MAKINUM(i));
+ i += ARRAY_DIMS(ra)[k].inc;
+ }
+ k--;
+ continue;
+ }
+ if (vinds[k] < ARRAY_DIMS(ra)[k].ubnd) {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
+ k--;
+ } while (k >= 0);
+ return UNSPECIFIED;
+ }
+ }
+}
+
+SCM array_equal P((SCM ra0, SCM ra1));
+static int raeql_1(ra0, as_equal, ra1)
+ SCM ra0, as_equal, ra1;
+{
+ SCM e0 = UNDEFINED, e1 = UNDEFINED;
+ sizet i0 = 0, i1 = 0;
+ long inc0 = 1, inc1 = 1;
+ sizet n = LENGTH(ra0);
+ ra1 = CAR(ra1);
+ if ARRAYP(ra0) {
+ n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
+ i0 = ARRAY_BASE(ra0);
+ inc0 = ARRAY_DIMS(ra0)->inc;
+ ra0 = ARRAY_V(ra0);
+ }
+ if ARRAYP(ra1) {
+ i1 = ARRAY_BASE(ra1);
+ inc1 = ARRAY_DIMS(ra1)->inc;
+ ra1 = ARRAY_V(ra1);
+ }
+ switch TYP7(ra0) {
+ case tc7_vector: default:
+ for (; n--; i0+=inc0, i1+=inc1) {
+ if FALSEP(as_equal) {
+ if FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))
+ return 0;
+ }
+ else
+ if FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)))
+ return 0;
+ }
+ return 1;
+ case tc7_string: {
+ char *v0 = CHARS(ra0) + i0;
+ char *v1 = CHARS(ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1) return 0;
+ return 1;
+ }
+ case tc7_bvect:
+ for (; n--; i0 += inc0, i1 += inc1)
+ if (BVE_REF(ra0, i0) != BVE_REF(ra1, i1)) return 0;
+ return 1;
+ case tc7_uvect: case tc7_ivect: {
+ long *v0 = (long *)VELTS(ra0) + i0;
+ long *v1 = (long *)VELTS(ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1) return 0;
+ return 1;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *v0 = (float *)VELTS(ra0) + i0;
+ float *v1 = (float *)VELTS(ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1) return 0;
+ return 1;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *v0 = (double *)VELTS(ra0) + i0;
+ double *v1 = (double *)VELTS(ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1) return 0;
+ return 1;
+ }
+ case tc7_cvect: {
+ double (*v0)[2]= (double (*)[2])VELTS(ra0) + i0;
+ double (*v1)[2] = (double (*)[2])VELTS(ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1) {
+ if ((*v0)[0] != (*v1)[0]) return 0;
+ if ((*v0)[1] != (*v1)[1]) return 0;
+ }
+ return 1;
+ }
+# endif /* FLOATS */
+ }
+}
+static int raeql(ra0, as_equal, ra1)
+ SCM ra0, as_equal, ra1;
+{
+ SCM v0 = ra0, v1 = ra1;
+ array_dim dim0, dim1;
+ array_dim *s0 = &dim0, *s1 = &dim1;
+ sizet bas0 = 0, bas1 = 0;
+ int k, unroll = 1, ndim = 1;
+ if ARRAYP(ra0) {
+ ndim = ARRAY_NDIM(ra0);
+ s0 = ARRAY_DIMS(ra0);
+ bas0 = ARRAY_BASE(ra0);
+ v0 = ARRAY_V(ra0);
+ }
+ else {
+ s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1;
+ }
+ if ARRAYP(ra1) {
+ if (ndim != ARRAY_NDIM(ra1)) return 0;
+ s1 = ARRAY_DIMS(ra1);
+ bas1 = ARRAY_BASE(ra1);
+ v1 = ARRAY_V(ra1);
+ }
+ else {
+ if (1 != ndim) return BOOL_F;
+ s1->inc = 1; s1->lbnd = 0; s1->ubnd = LENGTH(v1) - 1;
+ }
+ if (TYP7(v0) != TYP7(v1)) return 0;
+ unroll = (bas0==bas1);
+ for (k = ndim; k--;) {
+ if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) return 0;
+ if (unroll) unroll = (s0[k].inc==s1[k].inc);
+ }
+ if (unroll && v0==v1) return BOOL_T;
+ return ramapc(raeql_1, as_equal, ra0, cons(ra1, EOL), "");
+}
+
+SCM raequal(ra0, ra1)
+ SCM ra0, ra1;
+{
+ return (raeql(ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F);
+}
+static char s_array_equalp[] = "array-equal?";
+SCM array_equal(ra0, ra1)
+ SCM ra0, ra1;
+{
+ if (IMP(ra0) || IMP(ra1))
+ callequal: return equal(ra0, ra1);
+ switch TYP7(ra0) {
+ default: goto callequal;
+ case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
+ break;
+ case tc7_smob: if (!ARRAYP(ra0)) goto callequal;
+ }
+ switch TYP7(ra1) {
+ default: goto callequal;
+ case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
+ break;
+ case tc7_smob: if (!ARRAYP(ra1)) goto callequal;
+ }
+ return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
+}
+
+static iproc subr2os[] = {
+ {s_ura_rd, ura_read},
+ {s_ura_wr, ura_write},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_array_fill, array_fill},
+ {s_array_copy, array_copy},
+ {s_sarray_copy, array_copy},
+ {0, 0}};
+
+static iproc lsubr2s[] = {
+ {s_sc2array, sc2array},
+ {s_array_map, array_map},
+ {s_sarray_map, array_map},
+ {s_array_for_each, array_for_each},
+ {s_array_imap, array_imap},
+ {0, 0}};
+
+static void init_raprocs(subra)
+ ra_iproc *subra;
+{
+ for(; subra->name; subra++)
+ subra->sproc = CDR(intern(subra->name, strlen(subra->name)));
+}
+
+void init_ramap()
+{
+ init_raprocs(ra_rpsubrs);
+ init_raprocs(ra_asubrs);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ make_subr(s_array_equalp, tc7_rpsubr, array_equal);
+ smobs[0x0ff & (tc16_array>>8)].equalp = raequal;
+ add_feature(s_array_for_each);
+}
diff --git a/record.c b/record.c
new file mode 100644
index 0000000..40b224c
--- /dev/null
+++ b/record.c
@@ -0,0 +1,349 @@
+/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "record.c" code for (R5RS) proposed "Record" user definable datatypes.
+ Author: Radey Shouman */
+
+#include "scm.h"
+
+typedef struct {
+ SCM rtd;
+ SCM name;
+ SCM fields;
+} rtd_type;
+
+typedef union {
+ struct {
+ SCM proc;
+ SCM rtd;
+ } pred;
+ struct {
+ SCM proc;
+ SCM rtd;
+ SCM index;
+ } acc;
+ struct {
+ SCM proc;
+ SCM rtd;
+ SCM recsize;
+ SCM indices;
+ } constr;
+} rec_cclo;
+
+long tc16_record;
+
+/* Record-type-descriptor for record-type-descriptors */
+static SCM the_rtd_rtd;
+
+/* Record <= [rtd, ... elts ... ] */
+#define REC_RTD(x) (VELTS(x)[0])
+#define RECP(x) (tc16_record==TYP16(x))
+#define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x))
+#define RTD_NAME(x) (((rtd_type *)CDR(x))->name)
+#define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields)
+#define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd)
+
+#ifdef ARRAYS
+# define MAKE_REC_INDS(n) make_uve((long)n, MAKINUM(1))
+# define REC_IND_REF(x, i) VELTS(x)[(i)]
+# define REC_IND_SET(x, i, val) VELTS(x)[(i)] = (val)
+#else
+# define MAKE_REC_INDS(n) make_vector(MAKINUM(n), INUM0)
+# define REC_IND_REF(x, i) INUM(VELTS(x)[(i)])
+# define REC_IND_SET(x, i, val) VELTS(x)[(i)] = MAKINUM(val)
+#endif
+
+static char s_record[] = "record";
+static char s_recordp[] = "record?";
+SCM recordp(obj)
+ SCM obj;
+{
+ return (NIMP(obj) && RECP(obj) ? BOOL_T : BOOL_F);
+}
+static char s_rec_pred1[] = " record-predicate-procedure";
+SCM rec_pred1(cclo, obj)
+ SCM cclo, obj;
+{
+ if (NIMP(obj) && RECP(obj) && (REC_RTD(obj)==RCLO_RTD(cclo)))
+ return BOOL_T;
+ return BOOL_F;
+}
+static SCM f_rec_pred1;
+static char s_rec_pred[] = "record-predicate";
+SCM rec_pred(rtd)
+ SCM rtd;
+{
+ SCM cclo = makcclo(f_rec_pred1, 2L);
+ ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_pred);
+ RCLO_RTD(cclo) = rtd;
+ return cclo;
+}
+
+static char s_rec_rtd[] = "record-type-descriptor";
+SCM rec_rtd(rec)
+ SCM rec;
+{
+ if (IMP(rec) || !RECP(rec)) return BOOL_F;
+ return REC_RTD(rec);
+}
+
+static SCM f_rec_constr1;
+static char s_rec_constr[] = "record-constructor";
+SCM rec_constr(rtd, flds)
+ SCM rtd, flds;
+{
+ SCM flst, fld;
+ SCM cclo = makcclo(f_rec_constr1, (long)sizeof(rec_cclo)/sizeof(SCM));
+ rec_cclo *ptr = (rec_cclo *)CDR(cclo);
+ sizet i, j;
+ ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_constr);
+ ptr->constr.rtd = rtd;
+ i = ilength(RTD_FIELDS(rtd));
+ ptr->constr.recsize = MAKINUM(i);
+ if UNBNDP(flds) {
+ ptr->constr.indices = MAKE_REC_INDS(i);
+ while (i--)
+ REC_IND_SET(ptr->constr.indices, i, i+1);
+ }
+ else {
+ ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr);
+ ptr->constr.indices = MAKE_REC_INDS(ilength(flds));
+ for(i = 0; NIMP(flds); i++, flds = CDR(flds)) {
+ fld = CAR(flds);
+ ASSERT(NIMP(fld) && SYMBOLP(fld), fld, ARG2, s_rec_constr);
+ flst = RTD_FIELDS(rtd);
+ for (j = 0; ; j++, flst = CDR(flst)) {
+ if (fld==CAR(flst)) {
+ REC_IND_SET(ptr->constr.indices, i, j+1);
+ break;
+ }
+ ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
+ }
+ }
+ }
+ return cclo;
+}
+static char s_rec_constr1[] = " record-constructor-procedure";
+SCM rec_constr1(args)
+ SCM args;
+{
+ SCM cclo = CAR(args);
+ SCM rec, inds = (((rec_cclo *)CDR(cclo))->constr.indices);
+ sizet i = INUM(((rec_cclo *)CDR(cclo))->constr.recsize);
+ args = CDR(args);
+ NEWCELL(rec);
+ DEFER_INTS;
+ SETCHARS(rec, must_malloc((i+1L)*sizeof(SCM), s_record));
+ SETNUMDIGS(rec, i+1L, tc16_record);
+ ALLOW_INTS;
+ while (i--)
+ VELTS(rec)[i+1] = UNSPECIFIED;
+ REC_RTD(rec) = RCLO_RTD(cclo);
+ for (i = 0; i < LENGTH(inds); i++, args = CDR(args)) {
+ ASSERT(NNULLP(args), UNDEFINED, WNA, s_rec_constr1);
+ VELTS(rec)[ REC_IND_REF(inds, i) ] = CAR(args);
+ }
+ ASSERT(NULLP(args), UNDEFINED, WNA, s_rec_constr1);
+ return rec;
+
+}
+
+/* Makes an accessor or modifier.
+ A cclo with 2 env elts -- rtd and field-number. */
+static SCM makrecclo(proc, rtd, field, what)
+ SCM proc, rtd, field;
+ char *what;
+{
+ SCM flst;
+ SCM cclo = makcclo(proc, 3L);
+ int i;
+ ASSERT(RTDP(rtd), rtd, ARG1, what);
+ ASSERT(NIMP(field) && SYMBOLP(field), field, ARG2, what);
+ RCLO_RTD(cclo) = rtd;
+ flst = RTD_FIELDS(rtd);
+ for (i = 1; ; i++) {
+ ASSERT(NNULLP(flst), field, ARG2, what);
+ if (CAR(flst)==field) break;
+ flst = CDR(flst);
+ }
+ (((rec_cclo *)CDR(cclo))->acc.index) = MAKINUM(i);
+ return cclo;
+}
+static char s_rec_accessor1[] = " record-accessor-procedure";
+SCM rec_accessor1(cclo, rec)
+ SCM cclo, rec;
+{
+ ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_accessor1);
+ ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_accessor1);
+ return VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ];
+}
+static char s_rec_modifier1[] = " record-modifier-procedure";
+SCM rec_modifier1(cclo, rec, val)
+ SCM cclo, rec, val;
+{
+ ASSERT(NIMP(rec) && RECP(rec), rec, ARG1, s_rec_modifier1);
+ ASSERT(RCLO_RTD(cclo)==REC_RTD(rec), rec, ARG1, s_rec_modifier1);
+ VELTS(rec)[ INUM(((rec_cclo *)CDR(cclo))->acc.index) ] = val;
+ return UNSPECIFIED;
+}
+static SCM f_rec_accessor1;
+static char s_rec_accessor[] = "record-accessor";
+SCM rec_accessor(rtd, field)
+ SCM rtd, field;
+{
+ return makrecclo(f_rec_accessor1, rtd, field, s_rec_accessor);
+}
+static SCM f_rec_modifier1;
+static char s_rec_modifier[] = "record-modifier";
+SCM rec_modifier(rtd, field)
+ SCM rtd, field;
+{
+ return makrecclo(f_rec_modifier1, rtd, field, s_rec_accessor);
+}
+
+static char s_makrectyp[] = "make-record-type";
+SCM *loc_makrtd;
+SCM makrectyp(name, fields)
+ SCM name, fields;
+{
+ SCM n;
+#ifndef RECKLESS
+ if(ilength(fields) < 0)
+ errout: wta(fields, (char *)ARG2, s_makrectyp);
+ for (n=fields; NIMP(n); n = CDR(n))
+ if (!SYMBOLP(CAR(n))) goto errout;
+#endif
+ return apply(*loc_makrtd, name, cons(fields, listofnull));
+}
+
+static SCM markrec(ptr)
+ SCM ptr;
+{
+ sizet i;
+ if GC8MARKP(ptr) return BOOL_F;
+ SETGC8MARK(ptr);
+ for (i = NUMDIGS(ptr); --i;)
+ if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
+ return REC_RTD(ptr);
+}
+static sizet freerec(ptr)
+ CELLPTR ptr;
+{
+ must_free(CHARS(ptr));
+ return sizeof(SCM)*NUMDIGS(ptr);
+}
+static int recprin1(exp, port, writing)
+ SCM exp, port;
+ int writing;
+{
+ SCM names = RTD_FIELDS(REC_RTD(exp));
+ sizet i;
+ lputs("#s(", port);
+ iprin1(RTD_NAME(REC_RTD(exp)), port, 0);
+ for (i = 1; i < NUMDIGS(exp); i++) {
+ lputc(' ', port);
+ iprin1(CAR(names), port, 0);
+ names = CDR(names);
+ lputc(' ', port);
+ iprin1(VELTS(exp)[i], port, writing);
+ }
+ lputc(')', port);
+/*
+ lputs("#<record <", port);
+ iprin1(RTD_NAME(REC_RTD(exp)), port, 0);
+ lputc('>', port);
+ for(i = 1; i < NUMDIGS(exp); i++) {
+ lputc(' ', port);
+ iprin1(VELTS(exp)[i], port, writing);
+ }
+ lputc('>', port);
+*/
+ return 1;
+}
+SCM recequal(rec0, rec1)
+ SCM rec0, rec1;
+{
+ sizet i = NUMDIGS(rec0);
+ if (i != NUMDIGS(rec1)) return BOOL_F;
+ if (REC_RTD(rec0) != REC_RTD(rec1)) return BOOL_F;
+ while(--i)
+ if FALSEP(equal(VELTS(rec0)[i], VELTS(rec1)[i]))
+ return BOOL_F;
+ return BOOL_T;
+}
+static smobfuns recsmob = {markrec, freerec, recprin1, recequal};
+static iproc subr1s[] = {
+ {s_recordp, recordp},
+ {s_rec_pred, rec_pred},
+ {s_rec_rtd, rec_rtd},
+ {0, 0}};
+static iproc subr2s[] = {
+ {s_rec_accessor, rec_accessor},
+ {s_rec_modifier, rec_modifier},
+ {s_makrectyp, makrectyp},
+ {0, 0}};
+static char s_name[] = "name";
+static char s_fields[] = "fields";
+void init_record()
+{
+ SCM i_name = CAR(intern(s_name, (sizeof s_name)-1));
+ SCM i_fields = CAR(intern(s_fields, (sizeof s_fields)-1));
+ tc16_record = newsmob(&recsmob);
+ NEWCELL(the_rtd_rtd);
+ SETCHARS(the_rtd_rtd, must_malloc((long)sizeof(rtd_type), s_record));
+ SETNUMDIGS(the_rtd_rtd, (long)sizeof(rtd_type)/sizeof(SCM), tc16_record);
+ REC_RTD(the_rtd_rtd) = the_rtd_rtd;
+ RTD_NAME(the_rtd_rtd) = makfromstr(s_record, (sizeof s_record)-1);
+ RTD_FIELDS(the_rtd_rtd) = cons2(i_name, i_fields, EOL);
+ sysintern("record:rtd", the_rtd_rtd);
+ f_rec_pred1 = make_subr(s_rec_pred1, tc7_subr_2, rec_pred1);
+ f_rec_constr1 = make_subr(s_rec_constr1, tc7_lsubr, rec_constr1);
+ f_rec_accessor1 = make_subr(s_rec_accessor1, tc7_subr_2, rec_accessor1);
+ f_rec_modifier1 = make_subr(s_rec_modifier1, tc7_subr_3, rec_modifier1);
+ make_subr(s_rec_constr, tc7_subr_2o, rec_constr);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+ sysintern("record-type-descriptor?", rec_pred(the_rtd_rtd));
+ sysintern("record-type-name", rec_accessor(the_rtd_rtd, i_name));
+ sysintern("record-type-field-names", rec_accessor(the_rtd_rtd, i_fields));
+ loc_makrtd = &CDR(sysintern("RTD:make", rec_constr(the_rtd_rtd, UNDEFINED)));
+ add_feature(s_record);
+}
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 <termio.h>
+int set_erase()
+{
+ struct termio tin;
+
+ ioctl(0, TCGETA, &tin);
+ tin.c_cc[VERASE] = '\010';
+
+ ioctl(0, TCSETA,&tin);
+ return(0);
+}
+#endif
+
+unsigned char upcase[CHAR_CODE_LIMIT];
+unsigned char downcase[CHAR_CODE_LIMIT];
+unsigned char lowers[] = "abcdefghijklmnopqrstuvwxyz";
+unsigned char uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+extern int verbose;
+void init_tables()
+{
+ int i;
+ for(i = 0;i<CHAR_CODE_LIMIT;i++) upcase[i] = downcase[i] = i;
+ for(i = 0;i<sizeof lowers/sizeof(char);i++) {
+ upcase[lowers[i]] = uppers[i];
+ downcase[uppers[i]] = lowers[i];
+ }
+ verbose = 1; /* Here so that monitor info won't be */
+ /* printed while in init_storage. (BOOM) */
+}
+
+#ifdef EBCDIC
+char *charnames[] = {
+ "nul","soh","stx","etx", "pf", "ht", "lc","del",
+ 0 , 0 ,"smm", "vt", "ff", "cr", "so", "si",
+ "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
+ "can", "em", "cc", 0 ,"ifs","igs","irs","ius",
+ "ds","sos", "fs", 0 ,"byp", "lf","eob","pre",
+ 0 , 0 , "sm", 0 , 0 ,"enq","ack","bel",
+ 0 , 0 ,"syn", 0 , "pn", "rs", "uc","eot",
+ 0 , 0 , 0 , 0 ,"dc4","nak", 0 ,"sub",
+ "space", s_newline, "tab", "backspace", "return", "page", "null"};
+char charnums[] =
+"\000\001\002\003\004\005\006\007\
+\010\011\012\013\014\015\016\017\
+\020\021\022\023\024\025\026\027\
+\030\031\032\033\034\035\036\037\
+\040\041\042\043\044\045\046\047\
+\050\051\052\053\054\055\056\057\
+\060\061\062\063\064\065\066\067\
+\070\071\072\073\074\075\076\077\
+ \n\t\b\r\f\0";
+#endif /* def EBCDIC */
+#ifdef ASCII
+char *charnames[] = {
+ "nul","soh","stx","etx","eot","enq","ack","bel",
+ "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
+ "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
+ "can", "em","sub","esc", "fs", "gs", "rs", "us",
+ "space", s_newline, "tab", "backspace", "return", "page", "null", "del"};
+char charnums[] =
+"\000\001\002\003\004\005\006\007\
+\010\011\012\013\014\015\016\017\
+\020\021\022\023\024\025\026\027\
+\030\031\032\033\034\035\036\037\
+ \n\t\b\r\f\0\177";
+#endif /* def ASCII */
+char *isymnames[] = {
+ /* Special Forms */
+ /* NUM_ISPCSYMS ISPCSYMS here */
+ "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
+ "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
+ "#@define", "#@apply", "#@call-with-current-continuation",
+ /* user visible ISYMS */
+ /* other keywords */
+ /* Flags */
+ "#f", "#t", "#<undefined>", "#<eof>", "()", "#<unspecified>"
+ };
+
+static char s_read_char[] = "read-char", s_peek_char[] = "peek-char";
+char s_read[] = "read", s_write[] = "write", s_newline[] = "newline";
+static char s_display[] = "display", s_write_char[] = "write-char";
+
+static char s_eofin[] = "end of file in ";
+static char s_unknown_sharp[] = "unknown # object";
+
+static SCM lreadr P((SCM tok_buf, SCM port));
+static SCM lreadparen P((SCM tok_buf, SCM port, char *name));
+static sizet read_token P((int ic, SCM tok_buf, SCM port));
+
+void intprint(n, radix, port)
+ long n;
+ int radix;
+ SCM port;
+{
+ char num_buf[INTBUFLEN];
+ lfwrite(num_buf, (sizet)sizeof(char), iint2str(n, radix, num_buf), port);
+}
+
+void ipruk(hdr, ptr, port)
+ char *hdr;
+ SCM ptr;
+ SCM port;
+{
+ lputs("#<unknown-", port);
+ lputs(hdr, port);
+ if CELLP(ptr) {
+ lputs(" (0x", port);
+ intprint(CAR(ptr), 16, port);
+ lputs(" . 0x", port);
+ intprint(CDR(ptr), 16, port);
+ lputs(") @", port);
+ }
+ lputs(" 0x", port);
+ intprint(ptr, 16, port);
+ lputc('>', port);
+}
+
+void iprlist(hdr, exp, tlr, port, writing)
+ char *hdr, tlr;
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ lputs(hdr, port);
+ /* CHECK_INTS; */
+ iprin1(CAR(exp), port, writing);
+ exp = CDR(exp);
+ for(;NIMP(exp);exp = CDR(exp)) {
+ if NECONSP(exp) break;
+ lputc(' ', port);
+ /* CHECK_INTS; */
+ iprin1(CAR(exp), port, writing);
+ }
+ if NNULLP(exp) {
+ lputs(" . ", port);
+ iprin1(exp, port, writing);
+ }
+ lputc(tlr, port);
+}
+void iprin1(exp, port, writing)
+ SCM exp;
+ SCM port;
+int writing;
+{
+ register long i;
+taloop:
+ switch (7 & (int)exp) {
+ case 2:
+ case 6:
+ intprint(INUM(exp), 10, port);
+ break;
+ case 4:
+ if ICHRP(exp) {
+ i = ICHR(exp);
+ if (writing) lputs("#\\", port);
+ if (!writing) lputc((int)i, port);
+ else if ((i <= ' ') && charnames[i]) lputs(charnames[i], port);
+#ifndef EBCDIC
+ else if (i=='\177')
+ lputs(charnames[(sizeof charnames/sizeof(char *))-1], port);
+#endif /* ndef EBCDIC */
+ else if (i > '\177')
+ intprint(i, 8, port);
+ else lputc((int)i, port);
+ }
+ else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *))))
+ lputs(ISYMCHARS(exp), port);
+ else if ILOCP(exp) {
+ lputs("#@", port);
+ intprint((long)IFRAME(exp), 10, port);
+ lputc(ICDRP(exp)?'-':'+', port);
+ intprint((long)IDIST(exp), 10, port);
+ }
+ else goto idef;
+ break;
+ case 1: /* gloc */
+ lputs("#@", port);
+ exp = CAR(exp-1);
+ goto taloop;
+ default:
+ idef:
+ ipruk("immediate", exp, port);
+ break;
+ case 0:
+ switch TYP7(exp) {
+ case tcs_cons_gloc:
+ case tcs_cons_imcar:
+ case tcs_cons_nimcar:
+ iprlist("(", exp, ')', port, writing);
+ break;
+ case tcs_closures:
+ exp = CODE(exp);
+ iprlist("#<CLOSURE ", exp, '>', port, writing);
+ break;
+ case tc7_string:
+ if (writing) {
+ lputc('\"', port);
+ for(i = 0;i<LENGTH(exp);++i) switch (CHARS(exp)[i]) {
+ case '"':
+ case '\\':
+ lputc('\\', port);
+ default:
+ lputc(CHARS(exp)[i], port);
+ }
+ lputc('\"', port);
+ break;
+ }
+ case tcs_symbols:
+ lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
+ break;
+ case tc7_vector:
+ lputs("#(", port);
+ for(i = 0;i+1<LENGTH(exp);++i) {
+ /* CHECK_INTS; */
+ iprin1(VELTS(exp)[i], port, writing);
+ lputc(' ', port);
+ }
+ if (i<LENGTH(exp)) {
+ /* CHECK_INTS; */
+ iprin1(VELTS(exp)[i], port, writing);
+ }
+ lputc(')', port);
+ break;
+ case tc7_bvect:
+ case tc7_ivect:
+ case tc7_uvect:
+ case tc7_fvect:
+ case tc7_dvect:
+ case tc7_cvect:
+ raprin1(exp, port, writing);
+ break;
+ case tcs_subrs:
+ lputs("#<primitive-procedure ", port);
+ lputs(CHARS(SNAME(exp)), port);
+ lputc('>', port);
+ break;
+#ifdef CCLO
+ case tc7_cclo:
+ lputs("#<compiled-closure ", port);
+ iprin1(CCLO_SUBR(exp), port, writing);
+ lputc('>', port);
+ break;
+#endif
+ case tc7_contin:
+ lputs("#<continuation ", port);
+ intprint(LENGTH(exp), 10, port);
+ lputs(" @ ", port);
+ intprint((long)CHARS(exp), 16, port);
+ lputc('>', port);
+ break;
+ case tc7_port:
+ i = PTOBNUM(exp);
+ if (i<numptob && ptobs[i].print && (ptobs[i].print)(exp, port, writing))
+ break;
+ goto punk;
+ case tc7_smob:
+ i = SMOBNUM(exp);
+ if (i<numsmob && smobs[i].print && (smobs[i].print)(exp, port, writing))
+ break;
+ goto punk;
+ default: punk: ipruk("type", exp, port);
+ }
+ }
+}
+
+#ifdef __IBMC__
+# define MSDOS
+#endif
+#ifdef MSDOS
+# ifndef GO32
+# include <io.h>
+# include <conio.h>
+static int input_waiting(f)
+ FILE *f;
+{
+ if (feof(f)) return 1;
+ if (fileno(f)==fileno(stdin) && (isatty(fileno(stdin)))) return kbhit();
+ return -1;
+}
+# endif
+#else
+# ifdef _DCC
+# include <ioctl.h>
+# else
+# ifndef AMIGA
+# ifndef vms
+# ifdef MWC
+# include <sys/io.h>
+# else
+# ifndef THINK_C
+# ifndef ARM_ULIB
+# include <sys/ioctl.h>
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+
+# ifdef HAVE_SELECT
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# endif
+# endif
+
+static int input_waiting(f)
+ FILE *f;
+{
+# ifdef HAVE_SELECT
+ fd_set ifds;
+ struct timeval tv;
+
+ FD_ZERO(&ifds);
+ FD_SET(fileno(f), &ifds);
+ tv.tv_sec = 0;
+ tv.tv_usec = 0;
+ select((fileno(f) + 1), &ifds, (fd_set *) NULL, (fd_set *) NULL, &tv);
+ return FD_ISSET(fileno(f), &ifds);
+# else
+# ifdef FIONREAD
+ long remir;
+ if (feof(f)) return 1;
+ ioctl(fileno(f), FIONREAD, &remir);
+ return remir;
+# else
+ return -1;
+# endif
+# endif
+}
+#endif
+/* perhaps should undefine MSDOS from __IBMC__ here */
+#ifndef GO32
+static char s_char_readyp[]="char-ready?";
+SCM char_readyp(port)
+ SCM port;
+{
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
+ if (CRDYP(port) || !(BUF0 & CAR(port))) return BOOL_T;
+ return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F;
+}
+#endif
+
+SCM eof_objectp(x)
+ SCM x;
+{
+ return (EOF_VAL==x) ? BOOL_T : BOOL_F;
+}
+
+void lfflush(port) /* internal SCM call */
+ SCM port;
+{
+ sizet i = PTOBNUM(port);
+ (ptobs[i].fflush)(STREAM(port));
+}
+static char s_flush[] = "force-output";
+SCM lflush(port) /* user accessible as force-output */
+ SCM port;
+{
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush);
+ {
+ sizet i = PTOBNUM(port);
+ SYSCALL((ptobs[i].fflush)(STREAM(port)););
+ return UNSPECIFIED;
+ }
+}
+
+SCM lwrite(obj, port)
+ SCM obj, port;
+{
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write);
+ iprin1(obj, port, 1);
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE==errno) close_port(port);
+# endif
+#endif
+ return UNSPECIFIED;
+}
+SCM display(obj, port)
+ SCM obj, port;
+{
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_display);
+ iprin1(obj, port, 0);
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE==errno) close_port(port);
+# endif
+#endif
+ return UNSPECIFIED;
+}
+SCM newline(port)
+ SCM port;
+{
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_newline);
+ lputc('\n', port);
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE==errno) close_port(port);
+ else
+# endif
+#endif
+ if (port==cur_outp) lfflush(port);
+ return UNSPECIFIED;
+}
+SCM write_char(chr, port)
+ SCM chr, port;
+{
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG2, s_write_char);
+ ASSERT(ICHRP(chr), chr, ARG1, s_write_char);
+ lputc((int)ICHR(chr), port);
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE==errno) close_port(port);
+# endif
+#endif
+ return UNSPECIFIED;
+}
+
+FILE *trans = 0;
+SCM trans_on(fil)
+ SCM fil;
+{
+ transcript = open_file(fil, makfromstr("w", (sizet)sizeof(char)));
+ if FALSEP(transcript) trans = 0;
+ else trans = STREAM(transcript);
+ return UNSPECIFIED;
+}
+SCM trans_off()
+{
+ if (!FALSEP(transcript)) close_port(transcript);
+ transcript = BOOL_F;
+ trans = 0;
+ return UNSPECIFIED;
+}
+
+void lputc(c, port)
+ int c;
+ SCM port;
+{
+ sizet i = PTOBNUM(port);
+ SYSCALL((ptobs[i].fputc)(c, STREAM(port)););
+ if (trans && (port==def_outp || port==cur_errp))
+ SYSCALL(fputc(c, trans););
+}
+void lputs(s, port)
+ char *s;
+ SCM port;
+{
+ sizet i = PTOBNUM(port);
+ SYSCALL((ptobs[i].fputs)(s, STREAM(port)););
+ if (trans && (port==def_outp || port==cur_errp))
+ SYSCALL(fputs(s, trans););
+}
+int lfwrite(ptr, size, nitems, port)
+ char *ptr;
+ sizet size;
+ sizet nitems;
+ SCM port;
+{
+ int ret;
+ sizet i = PTOBNUM(port);
+ SYSCALL(ret = (ptobs[i].fwrite)
+ (ptr, size, nitems, STREAM(port)););
+ if (trans && (port==def_outp || port==cur_errp))
+ SYSCALL(fwrite(ptr, size, nitems, trans););
+ return ret;
+}
+
+int lgetc(port)
+ SCM port;
+{
+ FILE *f;
+ int c;
+ sizet i;
+ /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */
+ if CRDYP(port)
+ {
+ c = CGETUN(port);
+ CLRDY(port); /* Clear ungetted char */
+ return c;
+ }
+ f=STREAM(port);
+ i = PTOBNUM(port);
+#ifdef linux
+ c = (ptobs[i].fgetc)(f);
+#else
+ SYSCALL(c = (ptobs[i].fgetc)(f););
+#endif
+ if (trans && (f==stdin)) SYSCALL(fputc(c, trans););
+ return c;
+}
+void lungetc(c, port)
+ int c;
+ SCM port;
+{
+/* ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/
+ CUNGET(c, port);
+}
+
+SCM scm_read_char(port)
+ SCM port;
+{
+ int c;
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
+ c = lgetc(port);
+ if (EOF==c) return EOF_VAL;
+ return MAKICHR(c);
+}
+SCM peek_char(port)
+ SCM port;
+{
+ int c;
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_peek_char);
+ c = lgetc(port);
+ if (EOF==c) return EOF_VAL;
+ lungetc(c, port);
+ return MAKICHR(c);
+}
+
+char *grow_tok_buf(tok_buf)
+ SCM tok_buf;
+{
+ sizet len = LENGTH(tok_buf);
+ len += len / 2;
+ resizuve(tok_buf, (SCM)MAKINUM(len));
+ return CHARS(tok_buf);
+}
+
+static int flush_ws(port, eoferr)
+ SCM port;
+char *eoferr;
+{
+ register int c;
+ while(1) switch (c = lgetc(port)) {
+ case EOF:
+goteof:
+ if (eoferr) wta(UNDEFINED, s_eofin, eoferr);
+ return c;
+ case ';':
+lp:
+ switch (c = lgetc(port)) {
+ case EOF:
+ goto goteof;
+ default:
+ goto lp;
+ case LINE_INCREMENTORS:
+ break;
+ }
+ case LINE_INCREMENTORS:
+ if (port==loadport) linum++;
+ case WHITE_SPACES:
+ break;
+ default:
+ return c;
+ }
+}
+SCM lread(port)
+ SCM port;
+{
+ int c;
+ SCM tok_buf;
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read);
+ do {
+ c = flush_ws(port, (char *)NULL);
+ if (EOF==c) return EOF_VAL;
+ lungetc(c, port);
+ tok_buf = makstr(30L);
+ } while (EOF_VAL==(tok_buf = lreadr(tok_buf, port)));
+ return tok_buf;
+}
+static SCM lreadr(tok_buf, port)
+ SCM tok_buf;
+SCM port;
+{
+ int c;
+ sizet j;
+ SCM p;
+tryagain:
+ c = flush_ws(port, s_read);
+ switch (c) {
+/* case EOF: return EOF_VAL;*/
+#ifdef BRACKETS_AS_PARENS
+ case '[':
+#endif
+ case '(': return lreadparen(tok_buf, port, s_list);
+#ifdef BRACKETS_AS_PARENS
+ case ']':
+#endif
+ case ')': warn("unexpected \")\"", "");
+ goto tryagain;
+ case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL);
+ case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL);
+ case ',':
+ c = lgetc(port);
+ if ('@'==c) p = i_uq_splicing;
+ else {
+ lungetc(c, port);
+ p = i_unquote;
+ }
+ return cons2(p, lreadr(tok_buf, port), EOL);
+ case '#':
+ c = lgetc(port);
+ switch (c) {
+#ifdef BRACKETS_AS_PARENS
+ case '[':
+#endif
+ case '(':
+ p = lreadparen(tok_buf, port, s_vector);
+ return NULLP(p) ? nullvect : vector(p);
+ case 't': case 'T': return BOOL_T;
+ case 'f': case 'F': return BOOL_F;
+ case 'b': case 'B': case 'o': case 'O':
+ case 'd': case 'D': case 'x': case 'X':
+ case 'i': case 'I': case 'e': case 'E':
+ lungetc(c, port);
+ c = '#';
+ goto num;
+ case '*':
+ j = read_token(c, tok_buf, port);
+ p = istr2bve(CHARS(tok_buf)+1, (long)(j-1));
+ if (NFALSEP(p)) return p;
+ else goto unkshrp;
+ case '\\':
+ c = lgetc(port);
+ j = read_token(c, tok_buf, port);
+ if (j==1) return MAKICHR(c);
+ if (c >= '0' && c < '8') {
+ p = istr2int(CHARS(tok_buf), (long)j, 8);
+ if (NFALSEP(p)) return MAKICHR(INUM(p));
+ }
+ for (c = 0;c<sizeof charnames/sizeof(char *);c++)
+ if (charnames[c]
+ && (0==strcmp(charnames[c], CHARS(tok_buf))))
+ return MAKICHR(charnums[c]);
+ wta(UNDEFINED, "unknown # object: #\\", CHARS(tok_buf));
+ case '|':
+ j = 1; /* here j is the comment nesting depth */
+lp: c = lgetc(port);
+lpc: switch (c) {
+ case EOF:
+ wta(UNDEFINED, s_eofin, "balanced comment");
+ case LINE_INCREMENTORS:
+ if (port==loadport) linum++;
+ default:
+ goto lp;
+ case '|':
+ if ('#' != (c = lgetc(port))) goto lpc;
+ if (--j) goto lp;
+ break;
+ case '#':
+ if ('|' != (c = lgetc(port))) goto lpc;
+ ++j; goto lp;
+ }
+ goto tryagain;
+ case '.':
+ p = lreadr(tok_buf, port);
+ return EVAL(p, (SCM)EOL);
+ default: callshrp:
+ p = CDR(intern("read:sharp", (sizeof "read:sharp")-1));
+ if NIMP(p) {
+ p = apply(p, MAKICHR(c), acons(port, EOL, EOL));
+ if (UNSPECIFIED==p) goto tryagain;
+ return p;
+ }
+ unkshrp: wta((SCM)MAKICHR(c), s_unknown_sharp, "");
+ }
+ case '\"':
+ j = 0;
+ while ('\"' != (c = lgetc(port))) {
+ ASSERT(EOF != c, UNDEFINED, s_eofin, s_string);
+ if (j+1 >= LENGTH(tok_buf)) grow_tok_buf(tok_buf);
+ if (c=='\\') switch (c = lgetc(port)) {
+ case '\n': continue;
+ case '0': c = '\0'; break;
+ case 'f': c = '\f'; break;
+ case 'n': c = '\n'; break;
+ case 'r': c = '\r'; break;
+ case 't': c = '\t'; break;
+ case 'a': c = '\007'; break;
+ case 'v': c = '\v'; break;
+ }
+ CHARS(tok_buf)[j] = c;
+ ++j;
+ }
+ if (j==0) return nullstr;
+ CHARS(tok_buf)[j] = 0;
+ return makfromstr(CHARS(tok_buf), j);
+ case DIGITS:
+ case '.': case '-': case '+':
+num:
+ j = read_token(c, tok_buf, port);
+ p = istring2number(CHARS(tok_buf), (long)j, 10L);
+ if NFALSEP(p) return p;
+ if (c=='#') {
+ if ((j==2) && (lgetc(port)=='(')) {
+ lungetc('(', port);
+ c = CHARS(tok_buf)[1];
+ goto callshrp;
+ }
+ wta(UNDEFINED, s_unknown_sharp, CHARS(tok_buf));
+ }
+ goto tok;
+ default:
+ j = read_token(c, tok_buf, port);
+tok:
+ p = intern(CHARS(tok_buf), j);
+ return CAR(p);
+ }
+}
+
+#ifdef _UNICOS
+_Pragma("noopt"); /* # pragma _CRI noopt */
+#endif
+static sizet read_token(ic, tok_buf, port)
+ int ic;
+ SCM tok_buf;
+ SCM port;
+{
+ register sizet j = 1;
+ register int c = ic;
+ register char *p = CHARS(tok_buf);
+ p[0] = downcase[c];
+ while(1) {
+ if (j+1 >= LENGTH(tok_buf)) p = grow_tok_buf(tok_buf);
+ switch (c = lgetc(port)) {
+#ifdef BRACKETS_AS_PARENS
+ case '[': case ']':
+#endif
+ case '(': case ')': case '\"': case ';':
+ case ',': case '`': case '#':
+ case WHITE_SPACES:
+ case LINE_INCREMENTORS:
+ lungetc(c, port);
+ case EOF:
+ p[j] = 0;
+ return j;
+ default:
+ p[j++] = downcase[c];
+ }
+ }
+}
+#ifdef _UNICOS
+_Pragma("opt"); /* # pragma _CRI opt */
+#endif
+
+static SCM lreadparen(tok_buf, port, name)
+ SCM tok_buf;
+ SCM port;
+ char *name;
+{
+ SCM tmp, tl, ans;
+ int c = flush_ws(port, name);
+ if (')'==c
+#ifdef BRACKETS_AS_PARENS
+ || ']'==c
+#endif
+ ) return EOL;
+ lungetc(c, port);
+ if (i_dot==(tmp = lreadr(tok_buf, port))) {
+ ans = lreadr(tok_buf, port);
+ closeit:
+ if (')' != (c = flush_ws(port, name))
+#ifdef BRACKETS_AS_PARENS
+ && ']' != c
+#endif
+ )
+ wta(UNDEFINED, "missing close paren", "");
+ return ans;
+ }
+ ans = tl = cons(tmp, EOL);
+ while (')' != (c = flush_ws(port, name))
+#ifdef BRACKETS_AS_PARENS
+ && ']' != c
+#endif
+ ) {
+ lungetc(c, port);
+ if (i_dot==(tmp = lreadr(tok_buf, port))) {
+ CDR(tl) = lreadr(tok_buf, port);
+ goto closeit;
+ }
+ tl = (CDR(tl) = cons(tmp, EOL));
+ }
+ return ans;
+}
+
+/* These procedures implement synchronization primitives. Processors
+ with an atomic test-and-set instruction can use it here (and not
+ DEFER_INTS). */
+char s_tryarb[] = "try-arbiter";
+char s_relarb[] = "release-arbiter";
+long tc16_arbiter;
+SCM tryarb(arb)
+ SCM arb;
+{
+ ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_tryarb);
+ DEFER_INTS;
+ if (CAR(arb) & (1L<<16))
+ arb = BOOL_F;
+ else {
+ CAR(arb) = tc16_arbiter | (1L<<16);
+ arb = BOOL_T;
+ }
+ ALLOW_INTS;
+ return arb;
+}
+SCM relarb(arb)
+ SCM arb;
+{
+ ASSERT((TYP16(arb)==tc16_arbiter), arb, ARG1, s_relarb);
+ if (!(CAR(arb) & (1L<<16))) return BOOL_F;
+ CAR(arb) = tc16_arbiter;
+ return BOOL_T;
+}
+SCM makarb(name)
+ SCM name;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = name;
+ CAR(z) = tc16_arbiter;
+ return z;
+}
+static int prinarb(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<arbiter ", port);
+ if (CAR(exp) & (1L<<16)) lputs("locked ", port);
+ iprin1(CDR(exp), port, writing);
+ lputc('>', port);
+ return !0;
+}
+
+static char s_tryload[] = "try-load";
+#define s_load (&s_tryload[4])
+
+struct errdesc {char *msg;char *s_response;short parent_err;};
+struct errdesc errmsgs[] = {
+ {"Wrong number of args", 0, 0},
+ {"numerical overflow", 0, FPE_SIGNAL},
+ {"Argument out of range", 0, FPE_SIGNAL},
+ {"Could not allocate", "out-of-storage", 0},
+ {"EXIT", "end-of-program", -1},
+ {"hang up", "hang-up", EXIT},
+ {"user interrupt", "user-interrupt", 0},
+ {"arithmetic error", "arithmetic-error", 0},
+ {"bus error", 0, 0},
+ {"segment violation", 0, 0},
+ {"alarm", "alarm-interrupt", 0}
+};
+
+int errjmp_bad = 1, ints_disabled = 1, sig_deferred = 0, alrm_deferred;
+SCM err_exp, err_env;
+char *err_pos, *err_s_subr;
+cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL};
+cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL};
+SCM *loc_errobj = (SCM *)&tmp_errobj;
+SCM *loc_loadpath = (SCM *)&tmp_loadpath;
+SCM loadport = UNDEFINED;
+long linum = 1;
+int verbose = 1;
+long cells_allocated = 0, lcells_allocated = 0,
+ mallocated = 0, lmallocated = 0,
+ rt = 0, gc_rt, gc_time_taken;
+long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
+long gc_syms_collected;
+static void def_err_response P((void));
+
+int handle_it(i)
+ int i;
+{
+ char *name = errmsgs[i-WNA].s_response;
+ SCM proc;
+ if (errjmp_bad) return -1; /* sends it to def_err_response */
+ if (name) {
+ NEWCELL(proc); /* discard possibly-used cell */
+ proc = CDR(intern(name, (sizet)strlen(name)));
+ if NIMP(proc) {
+ apply(proc, EOL, EOL);
+ return i;
+ }
+ }
+ return errmsgs[i-WNA].parent_err;
+}
+static char s_eval_string[] = "eval-string";
+static char s_load_string[] = "load-string";
+SCM scm_eval_string(str)
+ SCM str;
+{
+ str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
+ str = lread(str);
+ return EVAL(str, (SCM)EOL);
+}
+SCM scm_load_string(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
+ s_load_string);
+ str = mkstrport(INUM0, str, OPN | RDNG, s_load_string);
+ while(1) {
+ SCM form = lread(str);
+ if (EOF_VAL==form) break;
+ SIDEVAL(form, EOL);
+ }
+ return BOOL_T;
+}
+
+SCM exitval; /* INUM with return value */
+extern char s_unexec[];
+SCM repl_driver(initpath)
+ char *initpath;
+{
+#ifdef _UNICOS
+ int i;
+#else
+ long i;
+#endif
+ CONT(rootcont)->stkbse = (STACKITEM *)&i;
+ i = setjmp(CONT(rootcont)->jmpbuf);
+#ifndef SHORT_INT
+ if (i) i = UNCOOK(i);
+#endif
+ /* printf("repl_driver got %d\n", i); */
+ drloop:
+ switch ((int)i) {
+ default: {
+ char *name = errmsgs[i-WNA].s_response;
+ if (name) {
+ SCM proc = CDR(intern(name, (sizet)strlen(name)));
+ if NIMP(proc) apply(proc, EOL, EOL);
+ }
+ if ((i = errmsgs[i-WNA].parent_err)) goto drloop;
+ def_err_response();
+ goto reset_toplvl;
+ }
+ case 0:
+ exitval = MAKINUM(EXIT_SUCCESS);
+ errjmp_bad = 0;
+ errno = 0;
+ alrm_deferred = 0;
+ sig_deferred = 0;
+ ints_disabled = 0;
+ if (dumped) {
+ lcells_allocated = cells_allocated;
+ lmallocated = mallocated;
+ rt = INUM(my_time());
+ gc_time_taken = 0;
+ }
+ else if (scm_ldfile(initpath)) /* load Scheme init files */
+ wta(*loc_errobj, "Could not open file", s_load);
+ scm_evstr("(boot-tail)"); /* initialization tail-call */
+ case -2: /* abrt */
+ reset_toplvl:
+ errjmp_bad = 0;
+ alrm_deferred = 0;
+ sig_deferred = 0;
+ ints_disabled = 0;
+
+ /* Closing the loading file turned out to be a bad idea. */
+ /* But I will leave the code here in case someone wants it. */
+#ifdef CLOSE_LOADING_PORTS_ON_ABORT
+ if (NIMP(loadport) && OPINPORTP(loadport)) {
+ if (verbose > 1) {
+ lputs("; Aborting load (closing): ", cur_errp);
+ display(*loc_loadpath, cur_errp);
+ newline(cur_errp);
+ }
+ close_port(loadport); /* close loading file. */
+ }
+#endif
+ *loc_loadpath = BOOL_F;
+ loadport = UNDEFINED;
+ repl();
+ err_pos = (char *)EXIT;
+ i = EXIT;
+ goto drloop; /* encountered EOF on stdin */
+ case -1: /* quit */
+ return exitval;
+ case -3: /* restart. */
+ return 0;
+#ifdef CAN_DUMP
+ case -4: /* dump */
+ igc(s_unexec, (STACKITEM *)0);
+ dumped = 1;
+ unexec(CHARS(*loc_errobj), execpath, 0, 0, 0);
+ goto reset_toplvl;
+#endif
+ }
+}
+
+SCM line_num()
+{
+ return MAKINUM(linum);
+}
+SCM prog_args()
+{
+ return progargs;
+}
+
+extern char s_heap[];
+extern sizet hplim_ind;
+extern CELLPTR *hplims;
+void growth_mon(obj, size, units)
+ char *obj;
+ long size;
+ char *units;
+{
+ if (verbose>2)
+ {
+ lputs("; grew ", cur_errp);
+ lputs(obj, cur_errp);
+ lputs(" to ", cur_errp);
+ intprint(size, 10, cur_errp);
+ lputc(' ', cur_errp);
+ lputs(units, cur_errp);
+ if ((verbose>4) && (obj==s_heap)) heap_report();
+ lputs("\n", cur_errp);
+ }
+}
+
+void gc_start(what)
+ char *what;
+{
+ if (verbose>3 && FPORTP(cur_errp)) {
+ ALLOW_INTS;
+ lputs(";GC(", cur_errp);
+ lputs(what, cur_errp);
+ lputs(")", cur_errp);
+ lfflush(cur_errp);
+ DEFER_INTS;
+ }
+ gc_rt = INUM(my_time());
+ gc_cells_collected = 0;
+ gc_malloc_collected = 0;
+ gc_ports_collected = 0;
+ gc_syms_collected = 0;
+}
+void gc_end()
+{
+ gc_rt = INUM(my_time()) - gc_rt;
+ gc_time_taken = gc_time_taken + gc_rt;
+ if (verbose>3) {
+ ALLOW_INTS;
+ if (!FPORTP(cur_errp)) lputs(";GC ", cur_errp);
+ intprint(time_in_msec(gc_rt), 10, cur_errp);
+ lputs(" cpu mSec, ", cur_errp);
+ intprint(gc_cells_collected, 10, cur_errp);
+ lputs(" cells, ", cur_errp);
+ intprint(gc_malloc_collected, 10, cur_errp);
+ lputs(" malloc, ", cur_errp);
+ intprint(gc_syms_collected, 10, cur_errp);
+ lputs(" syms, ", cur_errp);
+ intprint(gc_ports_collected, 10, cur_errp);
+ lputs(" ports collected\n", cur_errp);
+ lfflush(cur_errp);
+ DEFER_INTS;
+ }
+}
+void repl_report()
+{
+ if (verbose>1) {
+ lfflush(cur_outp);
+ lputs(";Evaluation took ", cur_errp);
+ intprint(time_in_msec(INUM(my_time())-rt), 10, cur_errp);
+ lputs(" mSec (", cur_errp);
+ intprint(time_in_msec(gc_time_taken), 10, cur_errp);
+ lputs(" in gc) ", cur_errp);
+ intprint(cells_allocated - lcells_allocated, 10, cur_errp);
+ lputs(" cells work, ", cur_errp);
+ intprint(mallocated - lmallocated, 10, cur_errp);
+ lputs(" bytes other\n", cur_errp);
+ lfflush(cur_errp);
+ }
+}
+SCM lroom(args)
+ SCM args;
+{
+ intprint(cells_allocated, 10, cur_errp);
+ lputs(" out of ", cur_errp);
+ intprint(heap_size, 10, cur_errp);
+ lputs(" cells in use, ", cur_errp);
+ intprint(mallocated, 10, cur_errp);
+ lputs(" bytes allocated (of ", cur_errp);
+ intprint(mtrigger, 10, cur_errp);
+ lputs(")\n", cur_errp);
+ if NIMP(args) {
+ heap_report();
+ lputs("\n", cur_errp);
+ stack_report();
+ }
+ return UNSPECIFIED;
+}
+void heap_report()
+{
+ sizet i = 0;
+ lputs("; heap segments:", cur_errp);
+ while(i<hplim_ind) {
+ lputs("\n; 0x", cur_errp);
+ intprint((long)hplims[i++], 16, cur_errp);
+ lputs(" - 0x", cur_errp);
+ intprint((long)hplims[i++], 16, cur_errp);
+ }
+}
+void exit_report()
+{
+ if (verbose>2) {
+ lputs(";Totals: ", cur_errp);
+ intprint(time_in_msec(INUM(my_time())), 10, cur_errp);
+ lputs(" mSec my time, ", cur_errp);
+ intprint(time_in_msec(INUM(your_time())), 10, cur_errp);
+ lputs(" mSec your time\n", cur_errp);
+ }
+}
+
+SCM prolixity(arg)
+ SCM arg;
+{
+ int old = verbose;
+ if (!UNBNDP(arg)) {
+ if FALSEP(arg) verbose = 1;
+ else verbose = INUM(arg);
+ }
+ return MAKINUM(old);
+}
+
+void repl()
+{
+ SCM x;
+ repl_report();
+ while(1) {
+ if OPOUTPORTP(cur_inp) { /* This case for curses window */
+ lfflush(cur_outp);
+ if (verbose) lputs(PROMPT, cur_inp);
+ lfflush(cur_inp);
+ }
+ else {
+ if (verbose) lputs(PROMPT, cur_outp);
+ lfflush(cur_outp);
+ }
+ lcells_allocated = cells_allocated;
+ lmallocated = mallocated;
+ x = lread(cur_inp);
+ rt = INUM(my_time());
+ gc_time_taken = 0;
+ if (EOF_VAL==x) break;
+ if (!CRDYP(cur_inp)) /* assure newline read (and transcripted) */
+ lungetc(lgetc(cur_inp), cur_inp);
+#ifdef __TURBOC__
+ if ('\n' != CGETUN(cur_inp))
+ if OPOUTPORTP(cur_inp) /* This case for curses window */
+ {lfflush(cur_outp); newline(cur_inp);}
+ else newline(cur_outp);
+#endif
+ x = EVAL(x, (SCM)EOL);
+ repl_report();
+ iprin1(x, cur_outp, 1);
+ lputc('\n', cur_outp);
+ }
+}
+SCM quit(n)
+ SCM n;
+{
+ if (UNBNDP(n) || BOOL_T==n) n = MAKINUM(EXIT_SUCCESS);
+ else if INUMP(n) exitval = n;
+ else exitval = MAKINUM(EXIT_FAILURE);
+ if (errjmp_bad) exit(INUM(exitval));
+ dowinds(EOL, ilength(dynwinds));
+ longjmp(CONT(rootcont)->jmpbuf, COOKIE(-1));
+}
+SCM abrt()
+{
+ if (errjmp_bad) exit(INUM(exitval));
+ dowinds(EOL, ilength(dynwinds));
+#ifdef CAUTIOUS
+ stacktrace = EOL;
+#endif
+ longjmp(CONT(rootcont)->jmpbuf, COOKIE(-2));
+}
+char s_restart[] = "restart";
+SCM restart()
+{
+ /* ASSERT(!dumped, UNDEFINED, "dumped can't", s_restart); */
+ dowinds(EOL, ilength(dynwinds));
+#ifdef CAUTIOUS
+ stacktrace = EOL;
+#endif
+ longjmp(CONT(rootcont)->jmpbuf, COOKIE(-3));
+}
+
+#ifdef CAN_DUMP
+char s_unexec[] = "unexec";
+SCM scm_unexec(newpath)
+ SCM newpath;
+{
+ ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_unexec);
+ *loc_errobj = newpath;
+# ifdef CAUTIOUS
+ stacktrace = EOL;
+# endif
+ longjmp(CONT(rootcont)->jmpbuf, COOKIE(-4));
+}
+#endif
+
+char s_execpath[] = "execpath";
+SCM scm_execpath(newpath)
+ SCM newpath;
+{
+ SCM retval = execpath ? makfrom0str(execpath) : BOOL_F;
+ if (UNBNDP(newpath))
+ return retval;
+ if (FALSEP(newpath)) {
+ if (execpath) free(execpath);
+ execpath = 0;
+ return retval;
+ }
+ ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
+ if (execpath) free(execpath);
+ execpath = scm_cat_path(0L, CHARS(newpath), 0L);
+ return retval;
+}
+
+void han_sig()
+{
+ sig_deferred = 0;
+ if (INT_SIGNAL != handle_it(INT_SIGNAL))
+ wta(UNDEFINED, (char *)INT_SIGNAL, "");
+}
+void han_alrm()
+{
+ alrm_deferred = 0;
+ if (ALRM_SIGNAL != handle_it(ALRM_SIGNAL))
+ wta(UNDEFINED, (char *)ALRM_SIGNAL, "");
+}
+
+SCM tryload(filename)
+ SCM filename;
+{
+ ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
+ {
+ SCM oloadpath = *loc_loadpath;
+ SCM oloadport = loadport;
+ long olninum = linum;
+ SCM port, newform = BOOL_F;
+ port = open_file(filename, makfromstr("r", (sizet)sizeof(char)));
+ if FALSEP(port) return port;
+ *loc_loadpath = filename;
+ loadport = port;
+ linum = 1;
+ while(1) {
+ SCM form = newform;
+ newform = lread(port);
+ if (EOF_VAL==newform) {
+ close_port(port);
+ linum = olninum;
+ loadport = oloadport;
+ *loc_loadpath = oloadpath;
+ SIDEVAL(form, EOL);
+ return BOOL_T;
+ }
+ SIDEVAL(form, EOL);
+ }
+ }
+ return BOOL_T;
+}
+#ifdef CAUTIOUS
+void scm_print_stack(stk)
+ SCM stk;
+{
+ switch (ilength(stk)) {
+ case -1:
+ lputs("\n; circular stacktrace!", cur_errp);
+ return;
+ case -2:
+ lputs("\n; stacktrace not a list?", cur_errp);
+ iprin1(stk, cur_errp, 1);
+ return;
+ default:
+ while NNULLP(stk) {
+ SCM ste = CAR(stk);
+ lputc('\n', cur_errp);
+ iprin1(ste, cur_errp, 1);
+ stk = CDR(stk);
+ }
+ }
+}
+SCM scm_stack_trace()
+{
+ if (0==ilength(stacktrace)) return BOOL_F;
+ scm_print_stack(stacktrace);
+ return BOOL_T;
+}
+#endif
+
+static void err_head(str)
+ char *str;
+{
+ int oerrno = errno;
+ exitval = MAKINUM(EXIT_FAILURE);
+ if NIMP(cur_outp) lfflush(cur_outp);
+ lputc('\n', cur_errp);
+ if(BOOL_F != *loc_loadpath) {
+ iprin1(*loc_loadpath, cur_errp, 1);
+ lputs(", line ", cur_errp);
+ intprint((long)linum, 10, cur_errp);
+ lputs(": ", cur_errp);
+ }
+ lfflush(cur_errp);
+ errno = oerrno;
+ if (cur_errp==def_errp) {
+ if (errno>0) perror(str);
+ fflush(stderr);
+ return;
+ }
+}
+void warn(str1, str2)
+ char *str1, *str2;
+{
+ err_head("WARNING");
+ lputs("WARNING: ", cur_errp);
+ lputs(str1, cur_errp);
+ lputs(str2, cur_errp);
+ lputc('\n', cur_errp);
+ lfflush(cur_errp);
+}
+
+SCM lerrno(arg)
+ SCM arg;
+{
+ int old = errno;
+ if (!UNBNDP(arg)) {
+ if FALSEP(arg) errno = 0;
+ else errno = INUM(arg);
+ }
+ return MAKINUM(old);
+}
+static char s_perror[] = "perror";
+SCM lperror(arg)
+ SCM arg;
+{
+ ASSERT(NIMP(arg) && STRINGP(arg), arg, ARG1, s_perror);
+ err_head(CHARS(arg));
+ return UNSPECIFIED;
+}
+static void def_err_response()
+{
+ SCM obj = *loc_errobj;
+#ifdef CAUTIOUS
+ SCM stk = stacktrace;
+#endif
+ DEFER_INTS;
+ err_head("ERROR");
+ lputs("ERROR: ", cur_errp);
+ if (err_s_subr && *err_s_subr) {
+ lputs(err_s_subr, cur_errp);
+ lputs(": ", cur_errp);
+ }
+ if (err_pos==(char *)ARG1 && UNBNDP(*loc_errobj)) err_pos = (char *)WNA;
+#ifdef nosve
+ if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp);
+ else if (WNA>(short)err_pos) {
+ lputs("Wrong type in arg", cur_errp);
+ lputc(err_pos ? '0'+(short)err_pos : ' ', cur_errp);
+ }
+#else
+ if ((~0x1fL) & (long)err_pos) lputs(err_pos, cur_errp);
+ else if (WNA>(long)err_pos) {
+ lputs("Wrong type in arg", cur_errp);
+ lputc(err_pos ? '0'+(int)err_pos : ' ', cur_errp);
+ }
+#endif
+ else {
+ lputs(errmsgs[((int)err_pos)-WNA].msg, cur_errp);
+ goto outobj;
+ }
+ if (IMP(obj) || SYMBOLP(obj) || (TYP16(obj)==tc7_port)
+ || (NFALSEP(procedurep(obj))) || (NFALSEP(numberp(obj)))) {
+outobj:
+ if (!UNBNDP(obj)) {
+ lputs(((long)err_pos==WNA)?" given ":" ", cur_errp);
+ iprin1(obj, cur_errp, 1);
+ }
+ }
+ else lputs(" (see errobj)", cur_errp);
+#ifdef CAUTIOUS
+ if NNULLP(stk) scm_print_stack(stk);
+#endif
+ if UNBNDP(err_exp) goto getout;
+ if NIMP(err_exp) {
+ lputs("\n; in expression: ", cur_errp);
+ if NCONSP(err_exp) iprin1(err_exp, cur_errp, 1);
+ else if (UNDEFINED==CDR(err_exp))
+ iprin1(CAR(err_exp), cur_errp, 1);
+ else iprlist("(... ", err_exp, ')', cur_errp, 1);
+ }
+ if NULLP(err_env) lputs("\n; in top level environment.", cur_errp);
+ else {
+ SCM env = err_env;
+ lputs("\n; in scope:", cur_errp);
+ while NNULLP(env) {
+ lputc('\n', cur_errp);
+ lputs("; ", cur_errp);
+ iprin1(CAR(CAR(env)), cur_errp, 1);
+ env = CDR(env);
+ }
+ }
+ getout:
+ lputc('\n', cur_errp);
+ lfflush(cur_errp);
+ err_exp = err_env = UNDEFINED;
+ if (errjmp_bad) {
+ iprin1(obj, cur_errp, 1);
+ lputs("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
+#ifdef vms
+ exit(EXIT_FAILURE);
+#else
+ exit(errno? (long)errno : EXIT_FAILURE);
+#endif
+ }
+ errno = 0;
+ ALLOW_INTS;
+}
+void everr(exp, env, arg, pos, s_subr)
+ SCM exp, env, arg;
+ char *pos, *s_subr;
+{
+ err_exp = exp;
+ err_env = env;
+ *loc_errobj = arg;
+ err_pos = pos;
+ err_s_subr = s_subr;
+#ifndef CAUTIOUS
+ if (((~0x1fL) & (long)pos) || (WNA>(long)pos)
+ || NIMP(dynwinds) || errjmp_bad)
+#endif
+ {
+ def_err_response();
+ dowinds(EOL, ilength(dynwinds));
+ abrt();
+ }
+#ifndef CAUTIOUS
+ /* We don't have to clear stacktrace because CAUTIOUS never gets here */
+ /* We don't have to dowinds() because dynwinds is EOL */
+ longjmp(CONT(rootcont)->jmpbuf, COOKIE((int)pos));
+ /* will do error processing at stack base */
+#endif
+}
+void wta(arg, pos, s_subr)
+ SCM arg;
+char *pos, *s_subr;
+{
+ everr(UNDEFINED, EOL, arg, pos, s_subr);
+}
+SCM cur_input_port()
+{
+ return cur_inp;
+}
+SCM cur_output_port()
+{
+ return cur_outp;
+}
+SCM cur_error_port()
+{
+ return cur_errp;
+}
+char s_cur_inp[] = "set-current-input-port";
+char s_cur_outp[] = "set-current-output-port";
+char s_cur_errp[] = "set-current-error-port";
+SCM set_inp(port)
+ SCM port;
+{
+ SCM oinp = cur_inp;
+ ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_cur_inp);
+ cur_inp = port;
+ return oinp;
+}
+SCM set_outp(port)
+ SCM port;
+{
+ SCM ooutp = cur_outp;
+ ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_outp);
+ cur_outp = port;
+ return ooutp;
+}
+SCM set_errp(port)
+ SCM port;
+{
+ SCM oerrp = cur_errp;
+ ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_cur_errp);
+ cur_errp = port;
+ return oerrp;
+}
+
+static iproc subr0s[] = {
+ {&s_cur_inp[4], cur_input_port},
+ {&s_cur_outp[4], cur_output_port},
+ {&s_cur_errp[4], cur_error_port},
+ {"transcript-off", trans_off},
+ {"program-arguments", prog_args},
+ {"line-number", line_num},
+ {"abort", abrt},
+ {s_restart, restart},
+#ifdef CAUTIOUS
+ {"stack-trace", scm_stack_trace},
+#endif
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {s_cur_inp, set_inp},
+ {s_cur_outp, set_outp},
+ {s_cur_errp, set_errp},
+ {"transcript-on", trans_on},
+ {s_tryload, tryload},
+ {s_load_string, scm_load_string},
+ {s_eval_string, scm_eval_string},
+ {s_perror, lperror},
+ {"make-arbiter", makarb},
+ {s_tryarb, tryarb},
+ {s_relarb, relarb},
+ {0, 0}};
+
+static iproc subr1os[] = {
+ {s_read, lread},
+ {s_read_char, scm_read_char},
+ {s_peek_char, peek_char},
+ {s_newline, newline},
+ {s_flush, lflush},
+#ifndef GO32
+ {s_char_readyp, char_readyp},
+#endif
+ {"quit", quit},
+ {"verbose", prolixity},
+ {"errno", lerrno},
+ {s_execpath, scm_execpath},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_write, lwrite},
+ {s_display, display},
+ {s_write_char, write_char},
+#ifdef CAN_DUMP
+ {s_unexec, scm_unexec},
+#endif
+ {0, 0}};
+
+static smobfuns arbsmob = {markcdr, free0, prinarb};
+char s_ccl[] = "char-code-limit";
+
+void init_repl( iverbose )
+ int iverbose;
+{
+ sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT));
+ loc_errobj = &CDR(sysintern("errobj", UNDEFINED));
+ loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F));
+ transcript = BOOL_F;
+ trans = 0;
+ linum = 1;
+ verbose = iverbose;
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1os, tc7_subr_1o);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2os, tc7_subr_2o);
+ make_subr("room", tc7_lsubr, lroom);
+#ifndef GO32
+ add_feature(s_char_readyp);
+#endif
+#ifdef CAN_DUMP
+ if (!execpath) execpath = dld_find_executable(CHARS(CAR(progargs)));
+ add_feature("dump");
+ scm_ldstr("\
+(define (dump file . thunk)\n\
+ (cond ((null? thunk) (set! *interactive* #f) (set! *argv* #f))\n\
+ ((not (car thunk)) (set! *argv* #f))\n\
+ ((boolean? (car thunk)))\n\
+ (else (set! boot-tail (car thunk))))\n\
+ (set! restart exec-self)\n\
+ (unexec file))\n\
+");
+#endif
+#ifdef ARM_ULIB
+ set_erase();
+#endif
+ tc16_arbiter = newsmob(&arbsmob);
+}
+void final_repl()
+{
+ loc_errobj = (SCM *)&tmp_errobj;
+ loc_loadpath = (SCM *)&tmp_loadpath;
+ loadport = UNDEFINED;
+ transcript = BOOL_F;
+ trans = 0;
+ linum = 1;
+}
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 <stdio.h>
+
+static char rcsid[] =
+ "$Id: rgx.c, v 1.20 1995/02/15 04:39:45 dpb Exp $";
+
+#ifdef HAVE_ALLOCA
+# include <alloca.h>
+# define ALLOCA_PROTECT typedef int foobazzz
+# define ALLOCA alloca
+#else
+# define ALLOCA_PROTECT SCM alloca_protect=EOL
+# define ALLOCA(size) \
+ (alloca_protect=cons(makstr((long)(size)), alloca_protect), \
+ (void *)CDR(CAR(alloca_protect)))
+
+#endif
+
+#ifdef _GNU_SOURCE
+/* following two lines stolen from GNU regex.c */
+# define CHAR_SET_SIZE 256
+# define ISUPPER(c) (isascii (c) && isupper (c))
+#endif
+
+/* forward function defs */
+
+SCM lregsearch();
+SCM lregsearchv();
+
+/* Posix regexp bindings. */
+
+static char s_regex[] = "regex";
+static char s_regcomp[] = "regcomp", s_regerror[] = "regerror";
+static char s_regexec[] = "regexec", s_regmatp[] = "regmatch?";
+static char s_regsearch[] = "regsearch", s_regmatch[] = "regmatch";
+static char s_regsearchv[] = "regsearchv", s_regmatchv[] = "regmatchv";
+static char s_stringsplit[] = "string-split";
+static char s_stringsplitv[] = "string-splitv";
+static char s_stringedit[] = "string-edit";
+
+#define s_error &s_regerror[3]
+
+#define RGX_INFO(obj) ((regex_info*)CDR(obj))
+#define RGX_PATTERN(obj) (((regex_info*)CDR(obj))->pattern)
+#define RGX(obj) (&((regex_info*)CDR(obj))->rgx)
+#ifndef _GNU_SOURCE
+# define RGX2(obj) (&((regex_info*)CDR(obj))->rgx_anchored)
+#endif
+
+#define FIXUP_REGEXP(prog) \
+{ \
+ if (STRINGP(prog)) \
+ prog = lregcomp(prog, UNDEFINED); \
+ if (NIMP(prog) && CONSP(prog) && STRINGP(CAR(prog)) && \
+ NIMP(CDR(prog)) && CONSP(CDR(prog)) && STRINGP(CAR(CDR(prog)))) \
+ prog = lregcomp(CAR(prog), CAR(CDR(prog))); \
+}
+
+typedef struct regex_info {
+ SCM pattern; /* string we compiled to create our reg exp */
+ regex_t rgx;
+#ifndef _GNU_SOURCE
+ int options; /* for anchored pattern when matching */
+ regex_t rgx_anchored;
+#endif
+} regex_info;
+
+sizet fregex(ptr)
+ CELLPTR ptr;
+{
+ regfree(RGX(ptr));
+#ifndef _GNU_SOURCE
+ /* options are null => we compiled the anchored pattern */
+ if (RGX_INFO(ptr)->options==NULL)
+ regfree(RGX2(ptr));
+#endif
+ free(CHARS(ptr));
+ return sizeof(regex_t);
+}
+
+int prinregex(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<regex ", port);
+ intprint(CDR(exp), 16, port);
+ lputc(' ', port);
+ iprin1(RGX_PATTERN(exp), port, writing);
+ lputc('>', port);
+ return 1;
+}
+
+SCM markregex(ptr)
+ SCM ptr;
+{
+ SETGC8MARK(ptr);
+ SETGC8MARK(RGX_PATTERN(ptr));
+ return BOOL_F;
+}
+
+int tc16_rgx;
+static smobfuns rgxsmob = {markregex, fregex, prinregex};
+
+SCM lregerror(scode)
+ SCM scode;
+{
+ int code, len;
+ SCM str;
+ ASSERT(INUMP(scode), scode, ARG1, s_regerror);
+ code = INUM(scode);
+ if (code < 0)
+ return makfromstr("Invalid code", sizeof("Invalid code")-1);
+ /* XXX - is regerror posix or not? */
+#ifdef __REGEXP_LIBRARY_H__
+ /* XXX - gnu regexp doesn't use the re parameter, so we will
+ ignore it in a very untidy way. */
+ len = regerror(code, 0, 0, 0);
+ str = makstr(len-1);
+ regerror(code, 0, CHARS(str), len);
+#else
+ str = makfromstr(s_error, (sizet)5);
+#endif
+ return str;
+}
+
+SCM lregcomp(pattern, flags)
+ SCM pattern, flags;
+{
+ SCM z;
+ int i, options;
+ regex_t *prog;
+ regex_info *info;
+ char *flagchars;
+#ifdef _GNU_SOURCE
+ int fastmap = 0;
+ int ignore_case = 0;
+ char *err_msg;
+#endif
+
+ ASSERT(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp);
+ ASSERT(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)),
+ flags, ARG2, s_regcomp);
+ NEWCELL(z);
+ DEFER_INTS;
+ SETCHARS(z, info=(regex_info*)must_malloc((long)sizeof(regex_info), s_regex));
+ prog = &(info->rgx);
+ CAR(z) = tc16_rgx;
+#ifdef __REGEXP_LIBRARY_H__
+ for(i=sizeof(regex_t);i--;((char *)prog)[i] = 0);
+# ifndef _GNU_SOURCE
+ {
+ regex_t *prog2;
+ prog2 = &(info->rgx_anchored);
+ for(i=sizeof(regex_t);i--;((char *)prog2)[i] = 0);
+ }
+# endif
+#endif
+
+ ALLOW_INTS;
+ info->pattern = pattern;
+
+#ifdef _GNU_SOURCE
+ options = RE_SYNTAX_POSIX_EXTENDED;
+#else
+ options = REG_EXTENDED;
+#endif
+
+ if (!UNBNDP(flags)) {
+ flagchars = CHARS(flags);
+ for (i=0; i<LENGTH(flags); i++)
+ switch (flagchars[i]) {
+#ifdef _GNU_SOURCE
+ case 'n':
+ options |= RE_HAT_LISTS_NOT_NEWLINE;
+ options &= (~RE_DOT_NEWLINE);
+ break;
+ case 'i':
+ ignore_case = 1;
+ break;
+ case '0':
+ options &= (~RE_DOT_NOT_NULL);
+ break;
+ case 'f':
+ fastmap = 1;
+ break;
+#else
+ case 'n':
+ options |= REG_NEWLINE;
+ break;
+ case 'i':
+ options |= REG_ICASE;
+ break;
+#endif
+ }
+ }
+
+#ifdef _GNU_SOURCE
+ DEFER_INTS;
+ if (fastmap)
+ prog->fastmap = must_malloc(CHAR_SET_SIZE, s_regex);
+
+ if (ignore_case) {
+ prog->translate = must_malloc(CHAR_SET_SIZE, s_regex);
+ for (i = 0; i < CHAR_SET_SIZE; i++)
+ prog->translate[i] = ISUPPER (i) ? tolower (i) : i;
+ }
+
+ re_set_syntax(options);
+ err_msg = (char *)re_compile_pattern(CHARS(pattern), LENGTH(pattern), prog);
+ ALLOW_INTS;
+ prog->regs_allocated = REGS_FIXED;
+
+ /* if error, compile using regcomp to get the error number */
+ if (err_msg) {
+ int i;
+ char *tmppat;
+ SCM protect;
+
+ /* Fixup in case pattern has null characters */
+ tmppat = CHARS(protect=makstr(LENGTH(pattern)));
+ bcopy(CHARS(pattern), tmppat, LENGTH(pattern));
+ for (i=0; i<LENGTH(pattern); i++)
+ if (tmppat[i] == 0)
+ tmppat[i] = ' ';
+
+ i = regcomp(prog, tmppat, options);
+ z = MAKINUM(i);
+ }
+#else
+ info->options = options;
+ i = regcomp(prog, CHARS(pattern), options);
+ if (i) z = MAKINUM(i);
+#endif
+ return z;
+}
+
+SCM lregexec(prog, str)
+ SCM prog, str;
+{
+ ALLOCA_PROTECT;
+
+ FIXUP_REGEXP(prog);
+ ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regexec);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regexec);
+
+#ifdef _GNU_SOURCE
+ return lregsearchv(prog, str, EOL);
+#else /* not _GNU_SOURCE */
+ {
+ size_t nsub;
+ SCM ans;
+ regmatch_t *pm;
+ int flags = 0; /* XXX - optional arg? */
+
+ nsub = RGX(prog)->re_nsub + 1; /* XXX - is this posix? */
+ pm = ALLOCA(nsub * sizeof(regmatch_t));
+ if (regexec(RGX(prog), CHARS(str), nsub, pm, flags) != 0)
+ ans = BOOL_F;
+ else {
+ ans = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
+ while (nsub--) {
+ VELTS(ans)[2*nsub+0] = MAKINUM(pm[nsub].rm_so);
+ VELTS(ans)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo);
+ }
+ }
+ return ans;
+ }
+#endif /* _GNU_SOURCE */
+}
+
+SCM lregmatp(prog, str)
+ SCM prog, str;
+{
+ FIXUP_REGEXP(prog);
+ ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regmatp);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regmatp);
+
+#ifdef _GNU_SOURCE
+ return (lregsearch(prog, str, EOL)==BOOL_F)?BOOL_F:BOOL_T;
+#else /* not _GNU_SOURCE */
+ {
+ int flags = 0; /* XXX - optional arg? */
+
+ flags = regexec(RGX(prog), CHARS(str), 0, NULL, flags);
+ if (!flags) return BOOL_T;
+ if (REG_NOMATCH!=flags) wta(MAKINUM(flags), s_error, s_regmatp);
+ return BOOL_F;
+ }
+#endif
+}
+
+#define SCALAR 0
+#define VECTOR 1
+
+#define MATCH 0
+#define SEARCH 1
+
+SCM lregsearchmatch(prog, str, args, search, vector)
+ SCM prog, str, args;
+ int vector, search;
+{
+ int len = ilength(args);
+ int start, size, nsub;
+ SCM matches;
+ ALLOCA_PROTECT;
+
+ FIXUP_REGEXP(prog);
+ ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regsearch);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_regsearch);
+ ASSERT(len<=2, args, WNA, s_regsearch);
+ ASSERT((len<1)||(INUMP(CAR(args))), CAR(args), ARG3, s_regsearch);
+ ASSERT((len<2)||(INUMP(CAR(CDR(args)))), CAR(CDR(args)), ARG4, s_regsearch);
+
+ start = (len>=1)?(INUM(CAR(args))):0;
+ size = (len>=2)?(INUM(CAR(CDR(args)))):LENGTH(str);
+
+#ifdef _GNU_SOURCE
+ {
+ int ret, dir=1;
+ struct re_registers regs, *pregs=NULL;
+
+ if (search && start<0)
+ start *= -1, dir = -1;
+
+ if (vector) {
+ pregs = &regs;
+ nsub = RGX(prog)->re_nsub + 1;
+ regs.num_regs = nsub;
+
+ regs.start = ALLOCA(nsub * sizeof(regoff_t));
+ regs.end = ALLOCA(nsub * sizeof(regoff_t));
+ }
+
+ if (search)
+ ret = re_search(RGX(prog), CHARS(str), size, start, dir*size, pregs);
+ else
+ ret = re_match(RGX(prog), CHARS(str), size, start, pregs);
+
+ if (ret < 0)
+ return BOOL_F;
+
+ if (!vector)
+ return MAKINUM(ret);
+
+ matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
+ while (nsub--) {
+ VELTS(matches)[2*nsub+0] = MAKINUM(regs.start[nsub]);
+ VELTS(matches)[2*nsub+1] = MAKINUM(regs.end[nsub]);
+ }
+ return matches;
+ }
+#else /* not _GNU_SOURCE */
+ {
+ regex_t *regexp;
+ regmatch_t *pm;
+ char *search_string;
+ if (size > LENGTH(str))
+ size = LENGTH(str);
+
+ if (start<0 || start >= size)
+ return BOOL_F;
+
+ if (size < LENGTH(str)) {
+ search_string = ALLOCA(size-start+1);
+ bcopy(CHARS(str)+start, search_string, size-start);
+ search_string[size-start] = 0;
+ } else
+ search_string = CHARS(str)+start;
+
+ nsub = RGX(prog)->re_nsub + 1;
+ pm = ALLOCA(nsub * sizeof(regmatch_t));
+ if (search)
+ regexp = RGX(prog);
+ else {
+ /* doing a match */
+ if (RGX_INFO(prog)->options) {
+ /* strlen & strcpy OK, posix patterns are null terminated */
+ char *pattern;
+
+ pattern = ALLOCA(strlen(CHARS(RGX_PATTERN(prog)))+2);
+ pattern[0] = '^';
+ strcpy(pattern+1, CHARS(RGX_PATTERN(prog)));
+ regcomp(RGX2(prog), pattern, RGX_INFO(prog)->options);
+ RGX_INFO(prog)->options = 0;
+ }
+ regexp = RGX2(prog);
+ }
+
+ if (regexec(regexp, search_string, nsub, pm, 0) != 0)
+ return BOOL_F;
+
+ if (vector) {
+ matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
+ while (nsub--) {
+ VELTS(matches)[2*nsub+0] = MAKINUM(pm[nsub].rm_so + start);
+ VELTS(matches)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo + start);
+ }
+ return matches;
+ }
+
+ if (search)
+ return MAKINUM(pm[0].rm_so + start);
+ else
+ return MAKINUM(pm[0].rm_eo - pm[0].rm_so);
+ }
+
+#endif /* _GNU_SOURCE */
+}
+
+SCM lregsearch(prog, str, args)
+ SCM prog, str, args;
+{
+ return lregsearchmatch(prog, str, args, SEARCH, SCALAR);
+}
+
+SCM lregsearchv(prog, str, args)
+ SCM prog, str, args;
+{
+ return lregsearchmatch(prog, str, args, SEARCH, VECTOR);
+}
+
+SCM lregmatch(prog, str, args)
+ SCM prog, str, args;
+{
+ return lregsearchmatch(prog, str, args, MATCH, SCALAR);
+}
+
+SCM lregmatchv(prog, str, args)
+ SCM prog, str, args;
+{
+ return lregsearchmatch(prog, str, args, MATCH, VECTOR);
+}
+
+SCM stringsplitutil(prog, str, vector)
+ SCM prog, str;
+ int vector;
+{
+ int anchor, match_start, match_end, num_substrings, num_elements;
+ int search_base;
+ SCM next_break, substrings, ret;
+ SCM st_start, st_end;
+
+ FIXUP_REGEXP(prog);
+ ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringsplit);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG2, s_stringsplit);
+
+ substrings = EOL;
+ anchor = 0;
+ search_base = 0;
+ num_substrings = 0;
+ next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
+
+ while (next_break != BOOL_F) {
+ match_start = INUM(VELTS(next_break)[0]);
+ match_end = INUM(VELTS(next_break)[1]);
+
+ if (match_start < match_end) {
+ substrings=cons2(MAKINUM(anchor), MAKINUM(match_start), substrings);
+ anchor = match_end;
+ num_substrings++;
+ }
+
+ search_base = ((match_end>search_base)?match_end:(search_base+1));
+ next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
+ }
+
+ /* get that tail bit */
+ if (anchor < LENGTH(str)) {
+ substrings = cons2(MAKINUM(anchor), MAKINUM(LENGTH(str)), substrings);
+ num_substrings++;
+ }
+
+ num_elements = vector?(2*num_substrings):num_substrings;
+ ret = make_vector(MAKINUM(num_elements), EOL);
+
+ while (num_substrings--) {
+ st_start = CAR(substrings);
+ st_end = CAR(CDR(substrings));
+
+ if (vector) {
+ VELTS(ret)[num_substrings*2+0] = st_start;
+ VELTS(ret)[num_substrings*2+1] = st_end;
+ } else
+ VELTS(ret)[num_substrings] = substring(str, st_start, st_end);
+
+ substrings = CDR(CDR(substrings));
+ }
+
+ return ret;
+}
+
+SCM lstringsplit(prog, str)
+ SCM prog, str;
+{
+ return stringsplitutil(prog, str, SCALAR);
+}
+
+SCM lstringsplitv(prog, str)
+ SCM prog, str;
+{
+ return stringsplitutil(prog, str, VECTOR);
+}
+
+typedef struct _item {
+ struct _item *next;
+ char *string;
+ int start;
+ int end;
+} *editItem;
+
+#define PUSH(list, string_parm, start_parm, end_parm) \
+ { \
+ editItem item; \
+ \
+ item = ALLOCA(sizeof(*item)); \
+ item->next = list; \
+ list = item; \
+ item->string = string_parm; \
+ item->start = start_parm; \
+ item->end = end_parm; \
+ }
+
+/* (string-edit <re> <edit-spec> <string> [<count>]) */
+SCM lstringedit(prog, editspec, args)
+ SCM prog, editspec, args;
+{
+ int match_start, match_end, search_base, editcount;
+ int total_len;
+ int i, args_len, anchor, maxsubnum;
+ int backslash;
+ char *ptr;
+ editItem editlist, substrings, edit;
+ SCM str, count, next_edit;
+ SCM result;
+ ALLOCA_PROTECT;
+
+ args_len = ilength(args);
+
+ FIXUP_REGEXP(prog);
+ ASSERT(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringedit);
+ ASSERT(NIMP(editspec) && STRINGP(editspec), editspec, ARG2, s_stringedit);
+ ASSERT((args_len==1)||(args_len==2), args, WNA, s_stringedit);
+
+ str = CAR(args);
+ ASSERT(NIMP(str)&&STRINGP(str), str, ARG3, s_stringedit);
+
+ if (args_len==2) {
+ count = CAR(CDR(args));
+ ASSERT(INUMP(count)||(count==BOOL_T), count, ARG4, s_stringedit);
+ } else
+ count = MAKINUM(1);
+
+ /* process the editspec - break it into a list of dotted pairs
+ * of integers for substrings to be inserted and
+ * integers representing matched subexpressions that
+ * should be inserted.
+ */
+
+ maxsubnum = RGX(prog)->re_nsub;
+ anchor = 0;
+ backslash = 0;
+ editlist = NULL;
+ ptr = CHARS(editspec);
+
+ for (i=0; i<LENGTH(editspec); i++) {
+ if (backslash && (ptr[i]>='0') && (ptr[i] <='9') &&
+ ((ptr[i]-'0')<=maxsubnum))
+ {
+ if ((i-1)>anchor)
+ PUSH(editlist, CHARS(editspec), anchor, i-1);
+
+ PUSH(editlist, CHARS(editspec), ptr[i]-'0', -1);
+ anchor = i+1;
+ }
+ backslash = (ptr[i] == '\\')?1:0;
+ }
+
+ if (anchor < LENGTH(editspec))
+ PUSH(editlist, CHARS(editspec), anchor, LENGTH(editspec));
+
+ /* now, reverse the list of edit items */
+ {
+ editItem prev, cur, next;
+
+ for (prev=NULL, cur=editlist; cur; prev=cur, cur=next) {
+ next = cur->next;
+ cur->next = prev;
+ }
+ editlist = prev;
+ }
+
+ anchor = 0;
+ search_base = 0;
+ editcount = 0;
+ substrings = NULL;
+
+ next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
+
+ while (next_edit != BOOL_F) {
+ if (INUMP(count) && (editcount==INUM(count)))
+ break;
+
+ match_start = INUM(VELTS(next_edit)[0]);
+ match_end = INUM(VELTS(next_edit)[1]);
+
+ if (match_start < match_end) {
+ PUSH(substrings, CHARS(str), anchor, match_start);
+ anchor = match_end;
+ }
+
+ for (edit=editlist; edit; edit=edit->next) {
+ if (edit->end == -1) {
+ /* A backslash number in the original editspec */
+ PUSH(substrings, CHARS(str),
+ INUM(VELTS(next_edit)[edit->start*2+0]),
+ INUM(VELTS(next_edit)[edit->start*2+1]));
+ } else
+ /* normal string in the editspec */
+ PUSH(substrings, edit->string, edit->start, edit->end);
+ }
+
+ editcount++;
+ search_base = ((match_end>search_base)?match_end:(search_base+1));
+ next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
+ }
+
+ /* get that tail bit */
+ if (anchor < LENGTH(str))
+ PUSH(substrings, CHARS(str), anchor, LENGTH(str));
+
+ /* assemble the result string */
+ for (edit=substrings, total_len=0; edit; edit=edit->next)
+ total_len += (edit->end - edit->start);
+
+ result = makstr(total_len);
+ ptr = CHARS(result) + total_len; /* point at the null at the end */
+
+ for (edit=substrings; edit; edit=edit->next) {
+ ptr -= (edit->end - edit->start);
+ bcopy(edit->string + edit->start, ptr, edit->end - edit->start);
+ }
+ return result;
+}
+#undef PUSH
+
+void init_rgx()
+{
+ tc16_rgx = newsmob(&rgxsmob);
+ make_subr(s_regcomp, tc7_subr_2o, lregcomp);
+ make_subr(s_regexec, tc7_subr_2, lregexec);
+ make_subr(s_regmatp, tc7_subr_2, lregmatp);
+ make_subr(s_regerror, tc7_subr_1, lregerror);
+ make_subr(s_regsearch, tc7_lsubr_2, lregsearch);
+ make_subr(s_regsearchv, tc7_lsubr_2, lregsearchv);
+ make_subr(s_regmatch, tc7_lsubr_2, lregmatch);
+ make_subr(s_regmatchv, tc7_lsubr_2, lregmatchv);
+ make_subr(s_stringsplit, tc7_subr_2, lstringsplit);
+ make_subr(s_stringsplitv, tc7_subr_2, lstringsplitv);
+ make_subr(s_stringedit, tc7_lsubr_2, lstringedit);
+ add_feature(s_regex);
+}
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<res, errout);
+ return (tc16_bigpos==TYP16(num) ? res : -res);
+ }
+# endif
+ errout: wta(num, pos, s_caller);
+}
+#ifdef FLOATS
+double num2dbl(num, pos, s_caller)
+ SCM num;
+ char *pos, *s_caller;
+{
+ if INUMP(num) return (double)INUM(num);
+ ASRTGO(NIMP(num), errout);
+ if REALP(num) return REALPART(num);
+#ifdef BIGDIG
+ if BIGP(num) return big2dbl(num);
+#endif
+ errout: wta(num, pos, s_caller);
+}
+#endif
+
+
+ /* Convert (arrays of) strings to SCM */
+SCM makfromstr(src, len)
+ char *src;
+ sizet len;
+{
+ SCM s;
+ register char *dst;
+ s = makstr((long)len);
+ dst = CHARS(s);
+ while (len--) *dst++ = *src++;
+ return s;
+}
+SCM makfrom0str(src)
+ char *src;
+{
+ if (!src) return BOOL_F;
+ return makfromstr(src, (sizet) strlen(src));
+}
+/* converts C array of strings to SCM list of strings. */
+/* If argc < 0, a null terminated array is assumed. */
+SCM makfromstrs(argc, argv)
+ int argc;
+ char **argv;
+{
+ int i = argc;
+ SCM lst = EOL;
+ if (0 > i) for(i = 0; argv[i]; i++);
+ while (i--) lst = cons(makfrom0str(argv[i]), lst);
+ return lst;
+}
+/* Converts SCM list of strings to NULL terminated array of strings. */
+/* INTS must be DEFERed around this call and the use of the returned array. */
+char **makargvfrmstrs(args, s_name)
+ SCM args;
+ char *s_name;
+{
+ char **argv;
+ int argc = ilength(args);
+ argv = (char **)must_malloc((1L+argc)*sizeof(char *), s_vector);
+ for(argc = 0; NNULLP(args); args=CDR(args), ++argc) {
+ ASSERT(NIMP(CAR(args)) && STRINGP(CAR(args)), CAR(args), ARG2, s_name);
+ {
+ sizet len = 1 + LENGTH(CAR(args));
+ char *dst = (char *)must_malloc((long)len, s_string);
+ char *src = CHARS(CAR(args));
+ while (len--) dst[len] = src[len];
+ argv[argc] = dst;
+ }
+ }
+ argv[argc] = 0;
+ return argv;
+}
+void must_free_argv(argv)
+ char **argv;
+{
+ char **av = argv;
+ while(!(*av)) free(*(av++));
+ free(argv);
+}
+
+ /* Hooks to call SCM from C */
+SCM scm_evstr(str)
+ char *str;
+{
+ SCM lsym;
+ NEWCELL(lsym);
+ SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
+ SETCHARS(lsym, str);
+ return scm_eval_string(lsym);
+}
+void scm_ldstr(str)
+ char *str;
+{
+ SCM lsym;
+ NEWCELL(lsym);
+ SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
+ SETCHARS(lsym, str);
+ scm_load_string(lsym);
+}
+int scm_ldfile(path)
+ char *path;
+{
+ SCM name = makfrom0str(path);
+ *loc_errobj = name;
+ return BOOL_F==tryload(name);
+}
+int scm_ldprog(path)
+ char *path;
+{
+ SCM name = makfrom0str(path);
+ *loc_errobj = name;
+ return
+ BOOL_F==scm_evstr("(try-load (in-vicinity (program-vicinity) errobj))");
+}
+
+ /* Get byte address of SCM array */
+#ifdef ARRAYS
+long aind P((SCM ra, SCM args, char *what));
+unsigned long scm_addr(args, s_name)
+ SCM args;
+ char *s_name;
+{
+ long pos;
+ unsigned long ptr = 0; /* gratuitous assignment squelches cc warn. */
+ SCM v;
+ ASRTGO(NIMP(args), wna);
+ v = CAR(args);
+ args = CDR(args);
+ if IMP(v) {goto badarg;}
+ else if ARRAYP(v) {
+ pos = aind(v, args, s_name);
+ v = ARRAY_V(v);
+ }
+ else {
+ if NIMP(args) {
+ ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_name);
+ pos = INUM(CAR(args));
+ ASRTGO(NULLP(CDR(args)), wna);
+ }
+ else if NULLP(args) pos = 0;
+ else {
+ ASSERT(INUMP(args), args, ARG2, s_name);
+ pos = INUM(args);
+ }
+ ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
+ }
+ switch TYP7(v) {
+ case tc7_string:
+ ptr = (unsigned long)&(CHARS(v)[pos]);
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ ptr = (unsigned long)&(((float *)CDR(v))[pos]);
+ break;
+# endif
+ case tc7_cvect: pos = 2 * pos;
+ case tc7_dvect: ptr = (unsigned long)&(((double *)CDR(v))[pos]);
+ break;
+# endif
+ case tc7_bvect: ASRTGO(0==(pos%LONG_BIT), outrng);
+ pos = pos/LONG_BIT;
+ case tc7_uvect:
+ case tc7_ivect:
+ case tc7_vector: ptr = (unsigned long)&(VELTS(v)[pos]);
+ break;
+ outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_name);
+ default:
+ badarg: wta(v, (char *)ARG1, s_name);
+ wna: wta(UNDEFINED, (char *)WNA, s_name);
+ }
+ return ptr;
+}
+#endif /* ARRAYS */
+
+void init_rope()
+{
+}
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<e) CHARS(str2)[j++] = CHARS(str1)[i++];
+ return UNSPECIFIED;
+}
+static char s_submr[] = "substring-move-right!";
+SCM submr(str1, start1, args)
+ SCM str1, start1, args;
+{
+ SCM end1, str2, start2;
+ long i, j, e;
+ ASSERT(3==ilength(args), args, WNA, s_submr);
+ end1 = CAR(args); args = CDR(args);
+ str2 = CAR(args); args = CDR(args);
+ start2 = CAR(args);
+ ASSERT(NIMP(str1) && STRINGP(str1), str1, ARG1, s_submr);
+ ASSERT(INUMP(start1), start1, ARG2, s_submr);
+ ASSERT(INUMP(end1), end1, ARG3, s_submr);
+ ASSERT(NIMP(str2) && STRINGP(str2), str2, ARG4, s_submr);
+ ASSERT(INUMP(start2), start2, ARG5, s_submr);
+ i = INUM(start1), j = INUM(start2), e = INUM(end1);
+ ASSERT(i <= LENGTH(str1) && i >= 0, start1, OUTOFRANGE, s_submr);
+ ASSERT(j <= LENGTH(str2) && j >= 0, start2, OUTOFRANGE, s_submr);
+ ASSERT(e <= LENGTH(str1) && e >= 0, end1, OUTOFRANGE, s_submr);
+ ASSERT((j = e-i+j) <= LENGTH(str2), start2, OUTOFRANGE, s_submr);
+ while(i<e) CHARS(str2)[--j] = CHARS(str1)[--e];
+ return UNSPECIFIED;
+}
+static char s_subfl[] = "substring-fill!";
+SCM subfl(str, start, args)
+ SCM str, start, args;
+{
+ SCM end, fill;
+ long i, e;
+ char c;
+ ASSERT(2==ilength(args), args, WNA, s_subfl);
+ end = CAR(args); args = CDR(args);
+ fill = CAR(args);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_subfl);
+ ASSERT(INUMP(start), start, ARG2, s_subfl);
+ ASSERT(INUMP(end), end, ARG3, s_subfl);
+ ASSERT(ICHRP(fill), fill, ARG4, s_subfl);
+ i = INUM(start), e = INUM(end);c = ICHR(fill);
+ ASSERT(i <= LENGTH(str) && i >= 0, start, OUTOFRANGE, s_subfl);
+ ASSERT(e <= LENGTH(str) && e >= 0, end, OUTOFRANGE, s_subfl);
+ while(i<e) CHARS(str)[i++] = c;
+ return UNSPECIFIED;
+}
+
+static char s_strnullp[] = "string-null?";
+SCM strnullp(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_strnullp);
+ if LENGTH(str) return BOOL_F;
+ else return BOOL_T;
+}
+
+static char s_appendb[] = "append!";
+SCM appendb(args)
+ SCM args;
+{
+ SCM arg;
+ tail:
+ if NULLP(args) return EOL;
+ arg = CAR(args);
+ ASSERT(NULLP(arg) || (NIMP(arg) && CONSP(arg)), arg, ARG1, s_appendb);
+ args = CDR(args);
+ if NULLP(args) return arg;
+ if NULLP(arg) goto tail;
+ CDR(last_pair(arg)) = appendb(args);
+ return arg;
+}
+
+static iproc lsubr2s[] = {
+ {s_subml, subml},
+ {s_submr, submr},
+ {s_subfl, subfl},
+ {0, 0}};
+
+void init_sc2()
+{
+ make_subr(s_last_pair, tc7_subr_1, last_pair);
+ make_subr(s_strnullp, tc7_subr_1, strnullp);
+ make_subr(s_appendb, tc7_lsubr, appendb);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ add_feature("rev2-procedures");
+ add_feature("rev3-procedures");
+}
diff --git a/scl.c b/scl.c
new file mode 100644
index 0000000..393d0f0
--- /dev/null
+++ b/scl.c
@@ -0,0 +1,2393 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "scl.c" non-IEEE utility functions and non-integer arithmetic.
+ Authors: Jerry D. Hedden and Aubrey Jaffer */
+
+#include "scm.h"
+
+#ifdef FLOATS
+# include <math.h>
+
+static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar",
+ s_magnitude[] = "magnitude", s_angle[] = "angle",
+ s_real_part[] = "real-part", s_imag_part[] = "imag-part",
+ s_in2ex[] = "inexact->exact";
+static char s_expt[] = "$expt", s_atan2[] = "$atan2";
+static char s_memv[] = "memv", s_assv[] = "assv";
+#endif
+
+SCM sys_protects[NUM_PROTECTS];
+sizet num_protects = NUM_PROTECTS;
+
+char s_inexactp[] = "inexact?";
+static char s_zerop[] = "zero?",
+ s_positivep[] = "positive?", s_negativep[] = "negative?";
+static char s_eqp[] = "=", s_lessp[] = "<", s_grp[] = ">";
+static char s_leqp[] = "<=", s_greqp[] = ">=";
+static char s_max[] = "max", s_min[] = "min";
+char s_sum[] = "+", s_difference[] = "-", s_product[] = "*",
+ s_divide[] = "/";
+static char s_number2string[] = "number->string",
+ s_str2number[] = "string->number";
+
+static char s_list_tail[] = "list-tail";
+static char s_str2list[] = "string->list";
+static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!";
+static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!";
+
+/*** NUMBERS -> STRINGS ***/
+#ifdef FLOATS
+int dblprec;
+static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
+ 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
+ 5e-11,5e-12,5e-13,5e-14,5e-15,
+ 5e-16,5e-17,5e-18,5e-19,5e-20};
+
+static sizet idbl2str(f, a)
+ double f;
+char *a;
+{
+ int efmt, dpt, d, i, wp = dblprec;
+ sizet ch = 0;
+ int exp = 0;
+
+ if (f==0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
+ if (f < 0.0) {f = -f;a[ch++]='-';}
+ else if (f > 0.0) ;
+ else goto funny;
+ if IS_INF(f) {
+ if (ch==0) a[ch++]='+';
+ funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
+ }
+# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
+ make-uniform-vector, from causing infinite loops. */
+ while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;}
+ while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;}
+# else
+ while (f < 1.0) {f *= 10.0; exp--;}
+ while (f > 10.0) {f /= 10.0; exp++;}
+# endif
+ if (f+fx[wp] >= 10.0) {f = 1.0; exp++;}
+ zero:
+# ifdef ENGNOT
+ dpt = (exp+9999)%3;
+ exp -= dpt++;
+ efmt = 1;
+# else
+ efmt = (exp < -3) || (exp > wp+2);
+ if (!efmt)
+ if (exp < 0) {
+ a[ch++] = '0';
+ a[ch++] = '.';
+ dpt = exp;
+ while (++dpt) a[ch++] = '0';
+ } else
+ dpt = exp+1;
+ else
+ dpt = 1;
+# endif
+
+ do {
+ d = f;
+ f -= d;
+ a[ch++] = d+'0';
+ if (f < fx[wp]) break;
+ if (f+fx[wp] >= 1.0) {
+ a[ch-1]++;
+ break;
+ }
+ f *= 10.0;
+ if (!(--dpt)) a[ch++] = '.';
+ } while (wp--);
+
+ if (dpt > 0)
+# ifndef ENGNOT
+ if ((dpt > 4) && (exp > 6)) {
+ d = (a[0]=='-'?2:1);
+ for (i = ch++; i > d; i--)
+ a[i] = a[i-1];
+ a[d] = '.';
+ efmt = 1;
+ } else
+# endif
+ {
+ while (--dpt) a[ch++] = '0';
+ a[ch++] = '.';
+ }
+ if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */
+ if (efmt && exp) {
+ a[ch++] = 'e';
+ if (exp < 0) {
+ exp = -exp;
+ a[ch++] = '-';
+ }
+ for (i = 10; i <= exp; i *= 10);
+ for (i /= 10; i; i /= 10) {
+ a[ch++] = exp/i + '0';
+ exp %= i;
+ }
+ }
+ return ch;
+}
+
+static sizet iflo2str(flt, str)
+ SCM flt;
+ char *str;
+{
+ sizet i;
+# ifdef SINGLES
+ if SINGP(flt) i = idbl2str(FLO(flt), str);
+ else
+# endif
+ i = idbl2str(REAL(flt), str);
+ if CPLXP(flt) {
+ if(0 <= IMAG(flt)) /* jeh */
+ str[i++] = '+'; /* jeh */
+ i += idbl2str(IMAG(flt), &str[i]);
+ str[i++] = 'i';
+ }
+ return i;
+}
+#endif /* FLOATS */
+
+sizet iint2str(num, rad, p)
+ long num;
+ int rad;
+ char *p;
+{
+ sizet j;
+ register int i = 1, d;
+ register long n = num;
+ if (n < 0) {n = -n; i++;}
+ for (n /= rad;n > 0;n /= rad) i++;
+ j = i;
+ n = num;
+ if (n < 0) {n = -n; *p++ = '-'; i--;}
+ while (i--) {
+ d = n % rad;
+ n /= rad;
+ p[i] = d + ((d < 10) ? '0' : 'a' - 10);
+ }
+ return j;
+}
+#ifdef BIGDIG
+static SCM big2str(b, radix)
+ SCM b;
+ register unsigned int radix;
+{
+ SCM t = copybig(b, 0); /* sign of temp doesn't matter */
+ register BIGDIG *ds = BDIGITS(t);
+ sizet i = NUMDIGS(t);
+ sizet j = radix==16 ? (BITSPERDIG*i)/4+2
+ : radix >= 10 ? (BITSPERDIG*i*241L)/800+2
+ : (BITSPERDIG*i)+2;
+ sizet k = 0;
+ sizet radct = 0;
+ sizet ch; /* jeh */
+ BIGDIG radpow = 1, radmod = 0;
+ SCM ss = makstr((long)j);
+ char *s = CHARS(ss), c;
+ while ((long) radpow * radix < BIGRAD) {
+ radpow *= radix;
+ radct++;
+ }
+ s[0] = tc16_bigneg==TYP16(b) ? '-' : '+';
+ while ((i || radmod) && j) {
+ if (k==0) {
+ radmod = (BIGDIG)divbigdig(ds, i, radpow);
+ k = radct;
+ if (!ds[i-1]) i--;
+ }
+ c = radmod % radix; radmod /= radix; k--;
+ s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
+ }
+ ch = s[0]=='-' ? 1 : 0; /* jeh */
+ if (ch < j) { /* jeh */
+ for(i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
+ resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */
+ }
+ return ss;
+}
+#endif
+SCM number2string(x, radix)
+ SCM x, radix;
+{
+ if UNBNDP(radix) radix=MAKINUM(10L);
+ else ASSERT(INUMP(radix), radix, ARG2, s_number2string);
+#ifdef FLOATS
+ if NINUMP(x) {
+ char num_buf[FLOBUFLEN];
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) return big2str(x, (unsigned int)INUM(radix));
+# ifndef RECKLESS
+ if (!(INEXP(x)))
+ badx: wta(x, (char *)ARG1, s_number2string);
+# endif
+# else
+ ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
+# endif
+ return makfromstr(num_buf, iflo2str(x, num_buf));
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
+ return big2str(x, (unsigned int)INUM(radix));
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_number2string);
+# endif
+#endif
+ {
+ char num_buf[INTBUFLEN];
+ return makfromstr(num_buf, iint2str(INUM(x), (int)INUM(radix), num_buf));
+ }
+}
+/* These print routines are stubbed here so that repl.c doesn't need
+ FLOATS or BIGDIGs conditionals */
+int floprint(sexp, port, writing)
+ SCM sexp;
+ SCM port;
+ int writing;
+{
+#ifdef FLOATS
+ char num_buf[FLOBUFLEN];
+ lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port);
+#else
+ ipruk("float", sexp, port);
+#endif
+ return !0;
+}
+int bigprint(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+#ifdef BIGDIG
+ exp = big2str(exp, (unsigned int)10);
+ lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
+#else
+ ipruk("bignum", exp, port);
+#endif
+ return !0;
+}
+/*** END nums->strs ***/
+
+/*** STRINGS -> NUMBERS ***/
+#ifdef BIGDIG
+SCM istr2int(str, len, radix)
+ char *str;
+ long len;
+ register long radix;
+{
+ sizet j;
+ register sizet k, blen = 1;
+ sizet i = 0;
+ int c;
+ SCM res;
+ register BIGDIG *ds;
+ register unsigned long t2;
+
+ if (0 >= len) return BOOL_F; /* zero length */
+ if (10==radix) j = 1+(84*len)/(BITSPERDIG*25);
+ else j = (8 < radix) ? 1+(4*len)/BITSPERDIG : 1+(3*len)/BITSPERDIG;
+ switch (str[0]) { /* leading sign */
+ case '-':
+ case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
+ }
+ res = mkbig(j, '-'==str[0]);
+ ds = BDIGITS(res);
+ for (k = j;k--;) ds[k] = 0;
+ do {
+ switch (c = str[i++]) {
+ case DIGITS:
+ c = c - '0';
+ goto accumulate;
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ c = c-'A'+10;
+ goto accumulate;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ c = c-'a'+10;
+ accumulate:
+ if (c >= radix) return BOOL_F; /* bad digit for radix */
+ k = 0;
+ t2 = c;
+ moretodo:
+ while(k < blen) {
+/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
+ t2 += ds[k]*radix;
+ ds[k++] = BIGLO(t2);
+ t2 = BIGDN(t2);
+ }
+ ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
+ if (t2) {blen++; goto moretodo;}
+ break;
+ default:
+ return BOOL_F; /* not a digit */
+ }
+ } while (i < len);
+ if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
+ if INUMP(res = big2inum(res, blen)) return res;
+ if (j==blen) return res;
+ return adjbig(res, blen);
+}
+#else
+SCM istr2int(str, len, radix)
+ register char *str;
+ long len;
+ register long radix;
+{
+ register long n = 0, ln;
+ register int c;
+ register int i = 0;
+ int lead_neg = 0;
+ if (0 >= len) return BOOL_F; /* zero length */
+ switch (*str) { /* leading sign */
+ case '-': lead_neg = 1;
+ case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
+ }
+
+ do {
+ switch (c = str[i++]) {
+ case DIGITS:
+ c = c - '0';
+ goto accumulate;
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ c = c-'A'+10;
+ goto accumulate;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ c = c-'a'+10;
+ accumulate:
+ if (c >= radix) return BOOL_F; /* bad digit for radix */
+ ln = n;
+ n = n * radix - c;
+ /* Negation is a workaround for HP700 cc bug */
+ if (n > ln || (-n > -MOST_NEGATIVE_FIXNUM)) goto ovfl;
+ break;
+ default:
+ return BOOL_F; /* not a digit */
+ }
+ } while (i < len);
+ if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl;
+ return MAKINUM(n);
+ ovfl: /* overflow scheme integer */
+ return BOOL_F;
+}
+#endif
+
+#ifdef FLOATS
+SCM istr2flo(str, len, radix)
+ register char *str;
+ register long len;
+ register long radix;
+{
+ register int c, i = 0;
+ double lead_sgn;
+ double res = 0.0, tmp = 0.0;
+ int flg = 0;
+ int point = 0;
+ SCM second;
+
+ if (i >= len) return BOOL_F; /* zero length */
+
+ switch (*str) { /* leading sign */
+ case '-': lead_sgn = -1.0; i++; break;
+ case '+': lead_sgn = 1.0; i++; break;
+ default : lead_sgn = 0.0;
+ }
+ if (i==len) return BOOL_F; /* bad if lone `+' or `-' */
+
+ if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */
+ if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
+ if (++i < len) return BOOL_F; /* `i' not last character */
+ return makdbl(0.0, lead_sgn);
+ }
+ do { /* check initial digits */
+ switch (c = str[i]) {
+ case DIGITS:
+ c = c - '0';
+ goto accum1;
+ case 'D': case 'E': case 'F':
+ if (radix==10) goto out1; /* must be exponent */
+ case 'A': case 'B': case 'C':
+ c = c-'A'+10;
+ goto accum1;
+ case 'd': case 'e': case 'f':
+ if (radix==10) goto out1;
+ case 'a': case 'b': case 'c':
+ c = c-'a'+10;
+ accum1:
+ if (c >= radix) return BOOL_F; /* bad digit for radix */
+ res = res * radix + c;
+ flg = 1; /* res is valid */
+ break;
+ default:
+ goto out1;
+ }
+ } while (++i < len);
+ out1:
+
+ /* if true, then we did see a digit above, and res is valid */
+ if (i==len) goto done;
+
+ /* By here, must have seen a digit,
+ or must have next char be a `.' with radix==10 */
+ if (!flg)
+ if (!(str[i]=='.' && radix==10))
+ return BOOL_F;
+
+ while (str[i]=='#') { /* optional sharps */
+ res *= radix;
+ if (++i==len) goto done;
+ }
+
+ if (str[i]=='/') {
+ while (++i < len) {
+ switch (c = str[i]) {
+ case DIGITS:
+ c = c - '0';
+ goto accum2;
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ c = c-'A'+10;
+ goto accum2;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ c = c-'a'+10;
+ accum2:
+ if (c >= radix) return BOOL_F;
+ tmp = tmp * radix + c;
+ break;
+ default:
+ goto out2;
+ }
+ }
+ out2:
+ if (tmp==0.0) return BOOL_F; /* `slash zero' not allowed */
+ if (i < len)
+ while (str[i]=='#') { /* optional sharps */
+ tmp *= radix;
+ if (++i==len) break;
+ }
+ res /= tmp;
+ goto done;
+ }
+
+ if (str[i]=='.') { /* decimal point notation */
+ if (radix != 10) return BOOL_F; /* must be radix 10 */
+ while (++i < len) {
+ switch (c = str[i]) {
+ case DIGITS:
+ point--;
+ res = res*10.0 + c-'0';
+ flg = 1;
+ break;
+ default:
+ goto out3;
+ }
+ }
+ out3:
+ if (!flg) return BOOL_F; /* no digits before or after decimal point */
+ if (i==len) goto adjust;
+ while (str[i]=='#') { /* ignore remaining sharps */
+ if (++i==len) goto adjust;
+ }
+ }
+
+ switch (str[i]) { /* exponent */
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'l': case 'L':
+ case 's': case 'S': {
+ int expsgn = 1, expon = 0;
+ if (radix != 10) return BOOL_F; /* only in radix 10 */
+ if (++i==len) return BOOL_F; /* bad exponent */
+ switch (str[i]) {
+ case '-': expsgn=(-1);
+ case '+': if (++i==len) return BOOL_F; /* bad exponent */
+ }
+ if (str[i] < '0' || str[i] > '9') return BOOL_F; /* bad exponent */
+ do {
+ switch (c = str[i]) {
+ case DIGITS:
+ expon = expon*10 + c-'0';
+ if (expon > MAXEXP) return BOOL_F; /* exponent too large */
+ break;
+ default:
+ goto out4;
+ }
+ } while (++i < len);
+ out4:
+ point += expsgn*expon;
+ }
+ }
+
+ adjust:
+ if (point >= 0)
+ while (point--) res *= 10.0;
+ else
+# ifdef _UNICOS
+ while (point++) res *= 0.1;
+# else
+ while (point++) res /= 10.0;
+# endif
+
+ done:
+ /* at this point, we have a legitimate floating point result */
+ if (lead_sgn==-1.0) res = -res;
+ if (i==len) return makdbl(res, 0.0);
+
+ if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */
+ if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
+ if (++i < len) return BOOL_F; /* `i' not last character */
+ return makdbl(0.0, res);
+ }
+
+ switch (str[i++]) {
+ case '-': lead_sgn = -1.0; break;
+ case '+': lead_sgn = 1.0; break;
+ case '@': { /* polar input for complex number */
+ /* get a `real' for angle */
+ second = istr2flo(&str[i], (long)(len-i), radix);
+ if (!(INEXP(second))) return BOOL_F; /* not `real' */
+ if (CPLXP(second)) return BOOL_F; /* not `real' */
+ tmp = REALPART(second);
+ return makdbl(res*cos(tmp), res*sin(tmp));
+ }
+ default: return BOOL_F;
+ }
+
+ /* at this point, last char must be `i' */
+ if (str[len-1] != 'i' && str[len-1] != 'I') return BOOL_F;
+ /* handles `x+i' and `x-i' */
+ if (i==(len-1)) return makdbl(res, lead_sgn);
+ /* get a `ureal' for complex part */
+ second = istr2flo(&str[i], (long)((len-i)-1), radix);
+ if (!(INEXP(second))) return BOOL_F; /* not `ureal' */
+ if (CPLXP(second)) return BOOL_F; /* not `ureal' */
+ tmp = REALPART(second);
+ if (tmp < 0.0) return BOOL_F; /* not `ureal' */
+ return makdbl(res, (lead_sgn*tmp));
+}
+#endif /* FLOATS */
+
+
+SCM istring2number(str, len, radix)
+ char *str;
+ long len;
+ long radix;
+{
+ int i = 0;
+ char ex = 0;
+ char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
+ SCM res;
+ if (len==1)
+ if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
+ return BOOL_F;
+
+ while ((len-i) >= 2 && str[i]=='#' && ++i)
+ switch (str[i++]) {
+ case 'b': case 'B': if (rx_p++) return BOOL_F; radix = 2; break;
+ case 'o': case 'O': if (rx_p++) return BOOL_F; radix = 8; break;
+ case 'd': case 'D': if (rx_p++) return BOOL_F; radix = 10; break;
+ case 'x': case 'X': if (rx_p++) return BOOL_F; radix = 16; break;
+ case 'i': case 'I': if (ex_p++) return BOOL_F; ex = 2; break;
+ case 'e': case 'E': if (ex_p++) return BOOL_F; ex = 1; break;
+ default: return BOOL_F;
+ }
+
+ switch (ex) {
+ case 1:
+ return istr2int(&str[i], len-i, radix);
+ case 0:
+ res = istr2int(&str[i], len-i, radix);
+ if NFALSEP(res) return res;
+#ifdef FLOATS
+ case 2: return istr2flo(&str[i], len-i, radix);
+#endif
+ }
+ return BOOL_F;
+}
+
+
+SCM string2number(str, radix)
+ SCM str, radix;
+{
+ if UNBNDP(radix) radix=MAKINUM(10L);
+ else ASSERT(INUMP(radix), radix, ARG2, s_str2number);
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
+ return istring2number(CHARS(str), LENGTH(str), INUM(radix));
+}
+/*** END strs->nums ***/
+
+#ifdef FLOATS
+SCM makdbl (x, y)
+ double x, y;
+{
+ SCM z;
+ if ((y==0.0) && (x==0.0)) return flo0;
+ NEWCELL(z);
+ DEFER_INTS;
+ if (y==0.0) {
+# ifdef SINGLES
+ float fx;
+# ifndef SINGLESONLY
+ if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x))
+# endif
+ {
+ CAR(z) = tc_flo;
+ FLO(z) = x;
+ ALLOW_INTS;
+ return z;
+ }
+# endif /* def SINGLES */
+ CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real");
+ CAR(z) = tc_dblr;
+ }
+ else {
+ CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex");
+ CAR(z) = tc_dblc;
+ IMAG(z) = y;
+ }
+ REAL(z) = x;
+ ALLOW_INTS;
+ return z;
+}
+
+SCM eqv(x, y)
+ SCM x, y;
+{
+ if (x==y) return BOOL_T;
+ if IMP(x) return BOOL_F;
+ if IMP(y) return BOOL_F;
+ /* this ensures that types and length are the same. */
+ if (CAR(x) != CAR(y)) return BOOL_F;
+ if NUMP(x) {
+# ifdef BIGDIG
+ if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
+# endif
+ if (REALPART(x) != REALPART(y)) return BOOL_F;
+ if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F;
+ return BOOL_T;
+ }
+ return BOOL_F;
+}
+SCM memv(x, lst) /* m.borza 12.2.91 */
+SCM x, lst;
+{
+ for(;NIMP(lst);lst = CDR(lst)) {
+ ASRTGO(CONSP(lst), badlst);
+ if NFALSEP(eqv(CAR(lst), x)) return lst;
+ }
+# ifndef RECKLESS
+ if (!(NULLP(lst)))
+ badlst: wta(lst, (char *)ARG2, s_memv);
+# endif
+ return BOOL_F;
+}
+SCM assv(x, alist) /* m.borza 12.2.91 */
+SCM x, alist;
+{
+ SCM tmp;
+ for(;NIMP(alist);alist = CDR(alist)) {
+ ASRTGO(CONSP(alist), badlst);
+ tmp = CAR(alist);
+ ASRTGO(NIMP(tmp) && CONSP(tmp), badlst);
+ if NFALSEP(eqv(CAR(tmp), x)) return tmp;
+ }
+# ifndef RECKLESS
+ if (!(NULLP(alist)))
+ badlst: wta(alist, (char *)ARG2, s_assv);
+# endif
+ return BOOL_F;
+}
+#endif /* FLOATS */
+
+SCM list_tail(lst, k)
+ SCM lst, k;
+{
+ register long i;
+ ASSERT(INUMP(k), k, ARG2, s_list_tail);
+ i = INUM(k);
+ while (i-- > 0) {
+ ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
+ lst = CDR(lst);
+ }
+ return lst;
+}
+
+SCM string2list(str)
+ SCM str;
+{
+ long i;
+ SCM res = EOL;
+ unsigned char *src;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
+ src = UCHARS(str);
+ for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res);
+ return res;
+}
+SCM string_copy(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
+ return makfromstr(CHARS(str), (sizet)LENGTH(str));
+}
+SCM string_fill(str, chr)
+ SCM str, chr;
+{
+ register char *dst, c;
+ register long k;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
+ ASSERT(ICHRP(chr), chr, ARG2, s_st_fill);
+ c = ICHR(chr);
+ dst = CHARS(str);
+ for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c;
+ return UNSPECIFIED;
+}
+SCM vector2list(v)
+ SCM v;
+{
+ SCM res = EOL;
+ long i;
+ SCM *data;
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
+ data = VELTS(v);
+ for(i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res);
+ return res;
+}
+SCM vector_fill(v, fill)
+ SCM v, fill;
+{
+ register long i;
+ register SCM *data;
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
+ data = VELTS(v);
+ for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill;
+ return UNSPECIFIED;
+}
+static SCM vector_equal(x, y)
+ SCM x, y;
+{
+ long i;
+ for(i = LENGTH(x)-1;i >= 0;i--)
+ if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F;
+ return BOOL_T;
+}
+SCM bigequal(x, y)
+ SCM x, y;
+{
+#ifdef BIGDIG
+ if (0==bigcomp(x, y)) return BOOL_T;
+#endif
+ return BOOL_F;
+}
+SCM floequal(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ if (REALPART(x) != REALPART(y)) return BOOL_F;
+ if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T;
+#endif
+ return BOOL_F;
+}
+SCM equal(x, y)
+ SCM x, y;
+{
+ CHECK_STACK;
+ tailrecurse: POLL;
+ if (x==y) return BOOL_T;
+ if IMP(x) return BOOL_F;
+ if IMP(y) return BOOL_F;
+ if (CONSP(x) && CONSP(y)) {
+ if FALSEP(equal(CAR(x), CAR(y))) return BOOL_F;
+ x = CDR(x);
+ y = CDR(y);
+ goto tailrecurse;
+ }
+ /* this ensures that types and length are the same. */
+ if (CAR(x) != CAR(y)) return BOOL_F;
+ switch (TYP7(x)) {
+ default: return BOOL_F;
+ case tc7_string: return st_equal(x, y);
+ case tc7_vector: return vector_equal(x, y);
+ case tc7_smob: {
+ int i = SMOBNUM(x);
+ if (!(i < numsmob)) return BOOL_F;
+ if (smobs[i].equalp) return (smobs[i].equalp)(x, y);
+ else return BOOL_F;
+ }
+ case tc7_bvect: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_cvect: case tc7_dvect: {
+ SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp;
+ if (pred) return (*pred)(x, y);
+ else return BOOL_F;
+ }
+ }
+ return BOOL_F;
+}
+
+SCM numberp(x)
+ SCM x;
+{
+ if INUMP(x) return BOOL_T;
+#ifdef FLOATS
+ if (NIMP(x) && NUMP(x)) return BOOL_T;
+#else
+# ifdef BIGDIG
+ if (NIMP(x) && NUMP(x)) return BOOL_T;
+# endif
+#endif
+ return BOOL_F;
+}
+#ifdef FLOATS
+SCM realp(x)
+ SCM x;
+{
+ if INUMP(x) return BOOL_T;
+ if IMP(x) return BOOL_F;
+ if REALP(x) return BOOL_T;
+# ifdef BIGDIG
+ if BIGP(x) return BOOL_T;
+# endif
+ return BOOL_F;
+}
+SCM intp(x)
+ SCM x;
+{
+ double r;
+ if INUMP(x) return BOOL_T;
+ if IMP(x) return BOOL_F;
+# ifdef BIGDIG
+ if BIGP(x) return BOOL_T;
+# endif
+ if (!INEXP(x)) return BOOL_F;
+ if CPLXP(x) return BOOL_F;
+ r = REALPART(x);
+ if (r==floor(r)) return BOOL_T;
+ return BOOL_F;
+}
+#endif /* FLOATS */
+
+SCM inexactp(x)
+ SCM x;
+{
+#ifdef FLOATS
+ if (NIMP(x) && INEXP(x)) return BOOL_T;
+#endif
+ return BOOL_F;
+}
+SCM eqp(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ SCM t;
+ if NINUMP(x) {
+# ifdef BIGDIG
+# ifndef RECKLESS
+ if (!(NIMP(x)))
+ badx: wta(x, (char *)ARG1, s_eqp);
+# endif
+ if BIGP(x) {
+ if INUMP(y) return BOOL_F;
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
+ ASRTGO(INEXP(y), bady);
+ bigreal:
+ return (REALP(y) && (big2dbl(x)==REALPART(y))) ? BOOL_T : BOOL_F;
+ }
+ ASRTGO(INEXP(x), badx);
+# else
+ ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
+# endif
+ if INUMP(y) {t = x; x = y; y = t; goto realint;}
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
+ ASRTGO(INEXP(y), bady);
+# else
+ ASRTGO(NIMP(y) && INEXP(y), bady);
+# endif
+ if (REALPART(x) != REALPART(y)) return BOOL_F;
+ if CPLXP(x)
+ return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F;
+ return CPLXP(y) ? BOOL_F : BOOL_T;
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return BOOL_F;
+# ifndef RECKLESS
+ if (!(INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_eqp);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_eqp);
+# endif
+# endif
+ realint:
+ return (REALP(y) && (((double)INUM(x))==REALPART(y))) ? BOOL_T : BOOL_F;
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
+ if INUMP(y) return BOOL_F;
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_eqp);
+# endif
+ return BOOL_F;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_eqp);
+ ASSERT(INUMP(y), y, ARG2, s_eqp);
+# endif
+#endif
+ return ((long)x==(long)y) ? BOOL_T : BOOL_F;
+}
+SCM lessp(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifdef BIGDIG
+# ifndef RECKLESS
+ if (!(NIMP(x)))
+ badx: wta(x, (char *)ARG1, s_lessp);
+# endif
+ if BIGP(x) {
+ if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F;
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
+ ASRTGO(REALP(y), bady);
+ return (big2dbl(x) < REALPART(y)) ? BOOL_T : BOOL_F;
+ }
+ ASRTGO(REALP(x), badx);
+# else
+ ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp);
+# endif
+ if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F;
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (REALPART(x) < big2dbl(y)) ? BOOL_T : BOOL_F;
+ ASRTGO(REALP(y), bady);
+# else
+ ASRTGO(NIMP(y) && REALP(y), bady);
+# endif
+ return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F;
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T;
+# ifndef RECKLESS
+ if (!(REALP(y)))
+ bady: wta(y, (char *)ARG2, s_lessp);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && REALP(y)))
+ bady: wta(y, (char *)ARG2, s_lessp);
+# endif
+# endif
+ return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F;
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
+ if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F;
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_lessp);
+# endif
+ return BIGSIGN(y) ? BOOL_F : BOOL_T;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_lessp);
+ ASSERT(INUMP(y), y, ARG2, s_lessp);
+# endif
+#endif
+ return ((long)x < (long)y) ? BOOL_T : BOOL_F;
+}
+SCM greaterp(x, y)
+ SCM x, y;
+{
+ return lessp(y, x);
+}
+SCM leqp(x, y)
+ SCM x, y;
+{
+ return BOOL_NOT(lessp(y, x));
+}
+SCM greqp(x, y)
+ SCM x, y;
+{
+ return BOOL_NOT(lessp(x, y));
+}
+SCM zerop(z)
+ SCM z;
+{
+#ifdef FLOATS
+ if NINUMP(z) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) return BOOL_F;
+# ifndef RECKLESS
+ if (!(INEXP(z)))
+ badz: wta(z, (char *)ARG1, s_zerop);
+# endif
+# else
+ ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
+# endif
+ return (z==flo0) ? BOOL_T : BOOL_F;
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(z) {
+ ASSERT(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
+ return BOOL_F;
+ }
+# else
+ ASSERT(INUMP(z), z, ARG1, s_zerop);
+# endif
+#endif
+ return (z==INUM0) ? BOOL_T: BOOL_F;
+}
+SCM positivep(x)
+ SCM x;
+{
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
+# ifndef RECKLESS
+ if (!(REALP(x)))
+ badx: wta(x, (char *)ARG1, s_positivep);
+# endif
+# else
+ ASSERT(NIMP(x) && REALP(x), x, ARG1, s_positivep);
+# endif
+ return (REALPART(x) > 0.0) ? BOOL_T : BOOL_F;
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_positivep);
+ return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_positivep);
+# endif
+#endif
+ return (x > INUM0) ? BOOL_T : BOOL_F;
+}
+SCM negativep(x)
+ SCM x;
+{
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T;
+# ifndef RECKLESS
+ if (!(REALP(x)))
+ badx: wta(x, (char *)ARG1, s_negativep);
+# endif
+# else
+ ASSERT(NIMP(x) && REALP(x), x, ARG1, s_negativep);
+# endif
+ return (REALPART(x) < 0.0) ? BOOL_T : BOOL_F;
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_negativep);
+ return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_negativep);
+# endif
+#endif
+ return (x < INUM0) ? BOOL_T : BOOL_F;
+}
+
+SCM lmax(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ double z;
+#endif
+ if UNBNDP(y) {
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_max);
+#endif
+ return x;
+ }
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) {
+ if INUMP(y) return BIGSIGN(x) ? y : x;
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (1==bigcomp(x, y)) ? y : x;
+ ASRTGO(REALP(y), bady);
+ z = big2dbl(x);
+ return (z < REALPART(y)) ? y : makdbl(z, 0.0);
+ }
+ ASRTGO(REALP(x), badx);
+# else
+ ASSERT(NIMP(x) && REALP(x), x, ARG1, s_max);
+# endif
+ if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x;
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (REALPART(x) < (z = big2dbl(y))) ? makdbl(z, 0.0) : x;
+ ASRTGO(REALP(y), bady);
+# else
+ ASRTGO(NIMP(y) && REALP(y), bady);
+# endif
+ return (REALPART(x) < REALPART(y)) ? y : x;
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return BIGSIGN(y) ? x : y;
+# ifndef RECKLESS
+ if (!(REALP(y)))
+ bady: wta(y, (char *)ARG2, s_max);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && REALP(y)))
+ bady: wta(y, (char *)ARG2, s_max);
+# endif
+# endif
+ return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_max);
+ if INUMP(y) return BIGSIGN(x) ? y : x;
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return (1==bigcomp(x, y)) ? y : x;
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_max);
+# endif
+ return BIGSIGN(y) ? x : y;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_max);
+ ASSERT(INUMP(y), y, ARG2, s_max);
+# endif
+#endif
+ return ((long)x < (long)y) ? y : x;
+}
+
+SCM lmin(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ double z;
+#endif
+ if UNBNDP(y) {
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_min);
+#endif
+ return x;
+ }
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) {
+ if INUMP(y) return BIGSIGN(x) ? x : y;
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (-1==bigcomp(x, y)) ? y : x;
+ ASRTGO(REALP(y), bady);
+ z = big2dbl(x);
+ return (z > REALPART(y)) ? y : makdbl(z, 0.0);
+ }
+ ASRTGO(REALP(x), badx);
+# else
+ ASSERT(NIMP(x) && REALP(x), x, ARG1, s_min);
+# endif
+ if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x;
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return (REALPART(x) > (z = big2dbl(y))) ? makdbl(z, 0.0) : x;
+ ASRTGO(REALP(y), bady);
+# else
+ ASRTGO(NIMP(y) && REALP(y), bady);
+# endif
+ return (REALPART(x) > REALPART(y)) ? y : x;
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return BIGSIGN(y) ? y : x;
+# ifndef RECKLESS
+ if (!(REALP(y)))
+ bady: wta(y, (char *)ARG2, s_min);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && REALP(y)))
+ bady: wta(y, (char *)ARG2, s_min);
+# endif
+# endif
+ return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_min);
+ if INUMP(y) return BIGSIGN(x) ? x : y;
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return (-1==bigcomp(x, y)) ? y : x;
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_min);
+# endif
+ return BIGSIGN(y) ? y : x;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_min);
+ ASSERT(INUMP(y), y, ARG2, s_min);
+# endif
+#endif
+ return ((long)x > (long)y) ? y : x;
+}
+
+SCM sum(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return INUM0;
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_sum);
+#endif
+ return x;
+ }
+#ifdef FLOATS
+ if NINUMP(x) {
+ SCM t;
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) {
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
+ }
+ ASRTGO(INEXP(y), bady);
+ bigreal: return makdbl(big2dbl(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
+ }
+ ASRTGO(INEXP(x), badx);
+# else
+ ASRTGO(NIMP(x) && INEXP(x), badx);
+# endif
+ if INUMP(y) {t = x; x = y; y = t; goto intreal;}
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
+# ifndef RECKLESS
+ else if (!(INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_sum);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_sum);
+# endif
+# endif
+ { double i = 0.0;
+ if CPLXP(x) i = IMAG(x);
+ if CPLXP(y) i += IMAG(y);
+ return makdbl(REALPART(x)+REALPART(y), i); }
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y)
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# endif
+ }
+ ASRTGO(INEXP(y), bady);
+# else
+ ASRTGO(NIMP(y) && INEXP(y), bady);
+# endif
+ intreal: return makdbl(INUM(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_sum);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# endif
+ }
+ }
+# else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_sum);
+# endif
+#endif
+ x = INUM(x)+INUM(y);
+ if FIXABLE(x) return MAKINUM(x);
+#ifdef BIGDIG
+ return long2big(x);
+#else
+# ifdef FLOATS
+ return makdbl((double)x, 0.0);
+# else
+ wta(y, (char *)OVFLOW, s_sum);
+# endif
+#endif
+}
+
+SCM difference(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ if NINUMP(x) {
+# ifndef RECKLESS
+ if (!(NIMP(x)))
+ badx: wta(x, (char *)ARG1, s_difference);
+# endif
+ if UNBNDP(y) {
+# ifdef BIGDIG
+ if BIGP(x) {
+ x = copybig(x, !BIGSIGN(x));
+ return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
+ big2inum(x, NUMDIGS(x)) : x;
+ }
+# endif
+ ASRTGO(INEXP(x), badx);
+ return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0);
+ }
+ if INUMP(y) return sum(x, MAKINUM(-INUM(y)));
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(x) {
+ if BIGP(y) return (NUMDIGS(x) < NUMDIGS(y)) ?
+ addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
+ addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
+ ASRTGO(INEXP(y), bady);
+ return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
+ }
+ ASRTGO(INEXP(x), badx);
+ if BIGP(y) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0);
+ ASRTGO(INEXP(y), bady);
+# else
+ ASRTGO(INEXP(x), badx);
+ ASRTGO(NIMP(y) && INEXP(y), bady);
+# endif
+ if CPLXP(x)
+ if CPLXP(y)
+ return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y));
+ else
+ return makdbl(REAL(x)-REALPART(y), IMAG(x));
+ return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
+ }
+ if UNBNDP(y) {x = -INUM(x); goto checkx;}
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# endif
+ }
+# ifndef RECKLESS
+ if (!(INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_difference);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_difference);
+# endif
+# endif
+ return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference);
+ if UNBNDP(y) {
+ x = copybig(x, !BIGSIGN(x));
+ return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
+ big2inum(x, NUMDIGS(x)) : x;
+ }
+ if INUMP(y) {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(y));
+ return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return addbig(zdigs, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
+# endif
+ }
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return (NUMDIGS(x) < NUMDIGS(y)) ?
+ addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
+ addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
+ }
+ if UNBNDP(y) {x = -INUM(x); goto checkx;}
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_difference);
+# endif
+ {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# endif
+ }
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_difference);
+ if UNBNDP(y) {x = -INUM(x); goto checkx;}
+ ASSERT(INUMP(y), y, ARG2, s_difference);
+# endif
+#endif
+ x = INUM(x)-INUM(y);
+ checkx:
+ if FIXABLE(x) return MAKINUM(x);
+#ifdef BIGDIG
+ return long2big(x);
+#else
+# ifdef FLOATS
+ return makdbl((double)x, 0.0);
+# else
+ wta(y, (char *)OVFLOW, s_difference);
+# endif
+#endif
+}
+
+SCM product(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return MAKINUM(1L);
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_product);
+#endif
+ return x;
+ }
+#ifdef FLOATS
+ if NINUMP(x) {
+ SCM t;
+# ifdef BIGDIG
+ ASRTGO(NIMP(x), badx);
+ if BIGP(x) {
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y));
+ ASRTGO(INEXP(y), bady);
+ bigreal: {
+ double bg = big2dbl(x);
+ return makdbl(bg*REALPART(y), CPLXP(y)?bg*IMAG(y):0.0); }
+ }
+ ASRTGO(INEXP(x), badx);
+# else
+ ASRTGO(NIMP(x) && INEXP(x), badx);
+# endif
+ if INUMP(y) {t = x; x = y; y = t; goto intreal;}
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
+# ifndef RECKLESS
+ else if (!(INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_product);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_product);
+# endif
+# endif
+ if CPLXP(x)
+ if CPLXP(y)
+ return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y),
+ REAL(x)*IMAG(y)+IMAG(x)*REAL(y));
+ else
+ return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y));
+ return makdbl(REALPART(x)*REALPART(y),
+ CPLXP(y)?REALPART(x)*IMAG(y):0.0);
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {
+ intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
+ {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y) ? (x>0) : (x<0));
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y) ? (x>0) : (x<0));
+# endif
+ }
+ }
+ ASRTGO(INEXP(y), bady);
+# else
+ ASRTGO(NIMP(y) && INEXP(y), bady);
+# endif
+ intreal: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {SCM t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y));
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_product);
+# endif
+ intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
+ {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return mulbig(&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y) ? (x>0) : (x<0));
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y) ? (x>0) : (x<0));
+# endif
+ }
+ }
+# else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_product);
+# endif
+#endif
+ {
+ long i, j, k;
+ i = INUM(x);
+ if (0==i) return x;
+ j = INUM(y);
+ k = i * j;
+ y = MAKINUM(k);
+ if (k != INUM(y) || k/i != j)
+#ifdef BIGDIG
+ { int sgn = (i < 0) ^ (j < 0);
+# ifndef DIGSTOOBIG
+ i = pseudolong(i);
+ j = pseudolong(j);
+ return mulbig((BIGDIG *)&i, DIGSPERLONG,
+ (BIGDIG *)&j, DIGSPERLONG, sgn);
+# else /* DIGSTOOBIG */
+ BIGDIG idigs[DIGSPERLONG];
+ BIGDIG jdigs[DIGSPERLONG];
+ longdigs(i, idigs);
+ longdigs(j, jdigs);
+ return mulbig(idigs, DIGSPERLONG, jdigs, DIGSPERLONG, sgn);
+# endif
+ }
+#else
+# ifdef FLOATS
+ return makdbl(((double)i)*((double)j), 0.0);
+# else
+ wta(y, (char *)OVFLOW, s_product);
+# endif
+#endif
+ return y;
+ }
+}
+
+SCM divide(x, y)
+ SCM x, y;
+{
+#ifdef FLOATS
+ double d, r, i, a;
+ if NINUMP(x) {
+# ifndef RECKLESS
+ if (!(NIMP(x)))
+ badx: wta(x, (char *)ARG1, s_divide);
+# endif
+ if UNBNDP(y) {
+# ifdef BIGDIG
+ if BIGP(x) return makdbl(1.0/big2dbl(x), 0.0);
+# endif
+ ASRTGO(INEXP(x), badx);
+ if REALP(x) return makdbl(1.0/REALPART(x), 0.0);
+ r = REAL(x); i = IMAG(x); d = r*r+i*i;
+ return makdbl(r/d, -i/d);
+ }
+# ifdef BIGDIG
+ if BIGP(x) {
+ SCM z;
+ if INUMP(y) {
+ z = INUM(y);
+ ASSERT(z, y, OVFLOW, s_divide);
+ if (1==z) return x;
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
+ return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ?
+ makdbl(big2dbl(x)/INUM(y), 0.0) : normbig(w);
+ }
+# ifndef DIGSTOOBIG
+ z = pseudolong(z);
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 3);
+# else
+ { BIGDIG zdigs[DIGSPERLONG];
+ longdigs(z, zdigs);
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 3);}
+# endif
+ return z ? z : makdbl(big2dbl(x)/INUM(y), 0.0);
+ }
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y), 3);
+ return z ? z : makdbl(big2dbl(x)/big2dbl(y), 0.0);
+ }
+ ASRTGO(INEXP(y), bady);
+ if REALP(y) return makdbl(big2dbl(x)/REALPART(y), 0.0);
+ a = big2dbl(x);
+ goto complex_div;
+ }
+# endif
+ ASRTGO(INEXP(x), badx);
+ if INUMP(y) {d = INUM(y); goto basic_div;}
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) {d = big2dbl(y); goto basic_div;}
+ ASRTGO(INEXP(y), bady);
+# else
+ ASRTGO(NIMP(y) && INEXP(y), bady);
+# endif
+ if REALP(y) {
+ d = REALPART(y);
+ basic_div: return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0);
+ }
+ a = REALPART(x);
+ if REALP(x) goto complex_div;
+ r = REAL(y); i = IMAG(y); d = r*r+i*i;
+ return makdbl((a*r+IMAG(x)*i)/d, (IMAG(x)*r-a*i)/d);
+ }
+ if UNBNDP(y) {
+ if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
+ return makdbl(1.0/((double)INUM(x)), 0.0);
+ }
+ if NINUMP(y) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(y), bady);
+ if BIGP(y) return makdbl(INUM(x)/big2dbl(y), 0.0);
+# ifndef RECKLESS
+ if (!(INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_divide);
+# endif
+# else
+# ifndef RECKLESS
+ if (!(NIMP(y) && INEXP(y)))
+ bady: wta(y, (char *)ARG2, s_divide);
+# endif
+# endif
+ if REALP(y) return makdbl(INUM(x)/REALPART(y), 0.0);
+ a = INUM(x);
+ complex_div:
+ r = REAL(y); i = IMAG(y); d = r*r+i*i;
+ return makdbl((a*r)/d, (-a*i)/d);
+ }
+#else
+# ifdef BIGDIG
+ if NINUMP(x) {
+ SCM z;
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide);
+ if UNBNDP(y) goto ov;
+ if INUMP(y) {
+ z = INUM(y);
+ if (!z) goto ov;
+ if (1==z) return x;
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
+ if (divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z)) goto ov;
+ return w;
+ }
+# ifndef DIGSTOOBIG
+ z = pseudolong(z);
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 3);
+# else
+ { BIGDIG zdigs[DIGSPERLONG];
+ longdigs(z, zdigs);
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 3);}
+# endif
+ } else {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y), 3);
+ }
+ if (!z) goto ov;
+ return z;
+ }
+ if UNBNDP(y) {
+ if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
+ goto ov;
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_divide);
+# endif
+ goto ov;
+ }
+# else
+ ASSERT(INUMP(x), x, ARG1, s_divide);
+ if UNBNDP(y) {
+ if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
+ goto ov;
+ }
+ ASSERT(INUMP(y), y, ARG2, s_divide);
+# endif
+#endif
+ {
+ long z = INUM(y);
+ if ((0==z) || INUM(x)%z) goto ov;
+ z = INUM(x)/z;
+ if FIXABLE(z) return MAKINUM(z);
+#ifdef BIGDIG
+ return long2big(z);
+#endif
+#ifdef FLOATS
+ ov: return makdbl(((double)INUM(x))/((double)INUM(y)), 0.0);
+#else
+ ov: wta(x, (char *)OVFLOW, s_divide);
+#endif
+ }
+}
+
+#ifdef FLOATS
+double lasinh(x)
+ double x;
+{
+ return log(x+sqrt(x*x+1));
+}
+
+double lacosh(x)
+ double x;
+{
+ return log(x+sqrt(x*x-1));
+}
+
+double latanh(x)
+ double x;
+{
+ return 0.5*log((1+x)/(1-x));
+}
+
+double ltrunc(x)
+ double x;
+{
+ if (x < 0.0) return -floor(-x);
+ return floor(x);
+}
+double round(x)
+ double x;
+{
+ double plus_half = x + 0.5;
+ double result = floor(plus_half);
+ /* Adjust so that the round is towards even. */
+ return (plus_half==result && plus_half / 2 != floor(plus_half / 2))
+ ? result - 1 : result;
+}
+
+struct dpair {double x, y;};
+
+void two_doubles(z1, z2, sstring, xy)
+ SCM z1, z2;
+ char *sstring;
+ struct dpair *xy;
+{
+ if INUMP(z1) xy->x = INUM(z1);
+ else {
+# ifdef BIGDIG
+ ASRTGO(NIMP(z1), badz1);
+ if BIGP(z1) xy->x = big2dbl(z1);
+ else {
+# ifndef RECKLESS
+ if (!(REALP(z1)))
+ badz1: wta(z1, (char *)ARG1, sstring);
+# endif
+ xy->x = REALPART(z1);}
+# else
+ {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
+ xy->x = REALPART(z1);}
+# endif
+ }
+ if INUMP(z2) xy->y = INUM(z2);
+ else {
+# ifdef BIGDIG
+ ASRTGO(NIMP(z2), badz2);
+ if BIGP(z2) xy->y = big2dbl(z2);
+ else {
+# ifndef RECKLESS
+ if (!(REALP(z2)))
+ badz2: wta(z2, (char *)ARG2, sstring);
+# endif
+ xy->y = REALPART(z2);}
+# else
+ {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
+ xy->y = REALPART(z2);}
+# endif
+ }
+}
+
+SCM expt(z1, z2)
+ SCM z1, z2;
+{
+ struct dpair xy;
+ two_doubles(z1, z2, s_expt, &xy);
+ return makdbl(pow(xy.x, xy.y), 0.0);
+}
+SCM latan2(z1, z2)
+ SCM z1, z2;
+{
+ struct dpair xy;
+ two_doubles(z1, z2, s_atan2, &xy);
+ return makdbl(atan2(xy.x, xy.y), 0.0);
+}
+SCM makrect(z1, z2)
+ SCM z1, z2;
+{
+ struct dpair xy;
+ two_doubles(z1, z2, s_makrect, &xy);
+ return makdbl(xy.x, xy.y);
+}
+SCM makpolar(z1, z2)
+ SCM z1, z2;
+{
+ struct dpair xy;
+ two_doubles(z1, z2, s_makpolar, &xy);
+ return makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
+}
+
+SCM real_part(z)
+ SCM z;
+{
+ if NINUMP(z) {
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) return z;
+# ifndef RECKLESS
+ if (!(INEXP(z)))
+ badz: wta(z, (char *)ARG1, s_real_part);
+# endif
+# else
+ ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
+# endif
+ if CPLXP(z) return makdbl(REAL(z), 0.0);
+ }
+ return z;
+}
+SCM imag_part(z)
+ SCM z;
+{
+ if INUMP(z) return INUM0;
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) return INUM0;
+# ifndef RECKLESS
+ if (!(INEXP(z)))
+ badz: wta(z, (char *)ARG1, s_imag_part);
+# endif
+# else
+ ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
+# endif
+ if CPLXP(z) return makdbl(IMAG(z), 0.0);
+ return flo0;
+}
+SCM magnitude(z)
+ SCM z;
+{
+ if INUMP(z) return absval(z);
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) return absval(z);
+# ifndef RECKLESS
+ if (!(INEXP(z)))
+ badz: wta(z, (char *)ARG1, s_magnitude);
+# endif
+# else
+ ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
+# endif
+ if CPLXP(z)
+ {
+ double i = IMAG(z), r = REAL(z);
+ return makdbl(sqrt(i*i+r*r), 0.0);
+ }
+ return makdbl(fabs(REALPART(z)), 0.0);
+}
+
+SCM angle(z)
+ SCM z;
+{
+ double x, y = 0.0;
+ if INUMP(z) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;}
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
+# ifndef RECKLESS
+ if (!(INEXP(z))) {
+ badz: wta(z, (char *)ARG1, s_angle);}
+# endif
+# else
+ ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle);
+# endif
+ if REALP(z) {x = REALPART(z); goto do_angle;}
+ x = REAL(z); y = IMAG(z);
+do_angle:
+ return makdbl(atan2(y, x), 0.0);
+}
+
+double floident(z)
+ double z;
+{
+ return z;
+}
+SCM in2ex(z)
+ SCM z;
+{
+ if INUMP(z) return z;
+# ifdef BIGDIG
+ ASRTGO(NIMP(z), badz);
+ if BIGP(z) return z;
+# ifndef RECKLESS
+ if (!(REALP(z)))
+ badz: wta(z, (char *)ARG1, s_in2ex);
+# endif
+# else
+ ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
+# endif
+# ifdef BIGDIG
+ {
+ double u = floor(REALPART(z)+0.5);
+ if ((u <= MOST_POSITIVE_FIXNUM) && (-u <= -MOST_NEGATIVE_FIXNUM)) {
+ /* Negation is a workaround for HP700 cc bug */
+ SCM ans = MAKINUM((long)u);
+ if (INUM(ans)==(long)u) return ans;
+ }
+ ASRTGO(!IS_INF(u), badz); /* problem? */
+ return dbl2big(u);
+ }
+# else
+ return MAKINUM((long)floor(REALPART(z)+0.5));
+# endif
+}
+#else /* ~FLOATS */
+static char s_trunc[] = "truncate";
+SCM numident(x)
+ SCM x;
+{
+ ASSERT(INUMP(x), x, ARG1, s_trunc);
+ return x;
+}
+#endif /* FLOATS */
+
+#ifdef BIGDIG
+# ifdef FLOATS
+SCM dbl2big(d)
+ double d; /* must be integer */
+{
+ sizet i = 0;
+ long c;
+ BIGDIG *digits;
+ SCM ans;
+ double u = (d < 0)?-d:d;
+ while (0 != floor(u)) {u /= BIGRAD;i++;}
+ ans = mkbig(i, d < 0);
+ digits = BDIGITS(ans);
+ while (i--) {
+ u *= BIGRAD;
+ c = floor(u);
+ u -= c;
+ digits[i] = c;
+ }
+ ASSERT(0==u, INUM0, OVFLOW, "dbl2big");
+ return ans;
+}
+double big2dbl(b)
+ SCM b;
+{
+ double ans = 0.0;
+ sizet i = NUMDIGS(b);
+ BIGDIG *digits = BDIGITS(b);
+ while (i--) ans = digits[i] + BIGRAD*ans;
+ if (tc16_bigneg==TYP16(b)) return -ans;
+ return ans;
+}
+# endif
+#endif
+
+unsigned long hasher(obj, n, d)
+ SCM obj;
+ unsigned long n;
+ sizet d;
+{
+ switch (7 & (int) obj) {
+ case 2: case 6: /* INUMP(obj) */
+ return INUM(obj) % n;
+ case 4:
+ if ICHRP(obj)
+ return (unsigned)(downcase[ICHR(obj)]) % n;
+ switch ((int) obj) {
+#ifndef SICP
+ case (int) EOL: d = 256; break;
+#endif
+ case (int) BOOL_T: d = 257; break;
+ case (int) BOOL_F: d = 258; break;
+ case (int) EOF_VAL: d = 259; break;
+ default: d = 263; /* perhaps should be error */
+ }
+ return d % n;
+ default: return 263 % n; /* perhaps should be error */
+ case 0:
+ switch TYP7(obj) {
+ default: return 263 % n;
+ case tc7_smob:
+ switch TYP16(obj) {
+ case tcs_bignums:
+ bighash: return INUM(modulo(obj, MAKINUM(n)));
+ default: return 263 % n;
+#ifdef FLOATS
+ case tc16_flo:
+ if REALP(obj) {
+ double r = REALPART(obj);
+ if (floor(r)==r) {
+ obj = in2ex(obj);
+ if IMP(obj) return INUM(obj) % n;
+ goto bighash;
+ }
+ }
+ obj = number2string(obj, MAKINUM(10));
+#endif
+ }
+ case tcs_symbols: case tc7_string:
+ return strhash(UCHARS(obj), (sizet) LENGTH(obj), n);
+ case tc7_vector: {
+ sizet len = LENGTH(obj);
+ SCM *data = VELTS(obj);
+ if (len>5) {
+ sizet i = d/2;
+ unsigned long h = 1;
+ while (i--) h = ((h<<8) + (hasher(data[h % len], n, 2))) % n;
+ return h;
+ }
+ else {
+ sizet i = len;
+ unsigned long h = (n)-1;
+ while (i--) h = ((h<<8) + (hasher(data[i], n, d/len))) % n;
+ return h;
+ }
+ }
+ case tcs_cons_imcar: case tcs_cons_nimcar:
+ if (d) return (hasher(CAR(obj), n, d/2)+hasher(CDR(obj), n, d/2)) % n;
+ else return 1;
+ case tc7_port:
+ return ((RDNG & CAR(obj)) ? 260 : 261) % n;
+ case tcs_closures: case tc7_contin: case tcs_subrs:
+ return 262 % n;
+ }
+ }
+}
+
+static char s_hashv[] = "hashv", s_hashq[] = "hashq";
+extern char s_obunhash[];
+#define s_hash (&s_obunhash[9])
+
+SCM hash(obj, n)
+ SCM obj;
+ SCM n;
+{
+ ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash);
+ return MAKINUM(hasher(obj, INUM(n), 10));
+}
+
+SCM hashv(obj, n)
+ SCM obj;
+ SCM n;
+{
+ ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
+ if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n));
+ if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10));
+ else return MAKINUM(obj % INUM(n));
+}
+
+SCM hashq(obj, n)
+ SCM obj;
+ SCM n;
+{
+ ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
+ return MAKINUM((((unsigned) obj) >> 1) % INUM(n));
+}
+
+static iproc subr1s[] = {
+ {"number?", numberp},
+ {"complex?", numberp},
+ {s_inexactp, inexactp},
+#ifdef FLOATS
+ {"real?", realp},
+ {"rational?", realp},
+ {"integer?", intp},
+ {s_real_part, real_part},
+ {s_imag_part, imag_part},
+ {s_magnitude, magnitude},
+ {s_angle, angle},
+ {s_in2ex, in2ex},
+#else
+ {"real?", numberp},
+ {"rational?", numberp},
+ {"integer?", exactp},
+ {"floor", numident},
+ {"ceiling", numident},
+ {s_trunc, numident},
+ {"round", numident},
+#endif
+ {s_zerop, zerop},
+ {s_positivep, positivep},
+ {s_negativep, negativep},
+ {s_str2list, string2list},
+ {"list->string", string},
+ {s_st_copy, string_copy},
+ {"list->vector", vector},
+ {s_vect2list, vector2list},
+ {0, 0}};
+
+static iproc asubrs[] = {
+ {s_difference, difference},
+ {s_divide, divide},
+ {s_max, lmax},
+ {s_min, lmin},
+ {s_sum, sum},
+ {s_product, product},
+ {0, 0}};
+
+static iproc subr2s[] = {
+#ifdef FLOATS
+ {s_makrect, makrect},
+ {s_makpolar, makpolar},
+ {s_memv, memv},
+ {s_assv, assv},
+ {s_atan2, latan2},
+ {s_expt, expt},
+#else
+ {"memv", memq},
+ {"assv", assq},
+#endif
+ {s_list_tail, list_tail},
+ {s_ve_fill, vector_fill},
+ {s_st_fill, string_fill},
+ {s_hash, hash},
+ {s_hashv, hashv},
+ {s_hashq, hashq},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_str2number, string2number},
+ {s_number2string, number2string},
+ {0, 0}};
+
+static iproc rpsubrs[] = {
+#ifdef FLOATS
+ {"eqv?", eqv},
+#else
+ {"eqv?", eq},
+#endif
+ {s_eqp, eqp},
+ {s_lessp, lessp},
+ {s_grp, greaterp},
+ {s_leqp, leqp},
+ {s_greqp, greqp},
+ {0, 0}};
+
+#ifdef FLOATS
+static dblproc cxrs[] = {
+ {"floor", floor},
+ {"ceiling", ceil},
+ {"truncate", ltrunc},
+ {"round", round},
+ {"$sqrt", sqrt},
+ {"$abs", fabs},
+ {"$exp", exp},
+ {"$log", log},
+ {"$sin", sin},
+ {"$cos", cos},
+ {"$tan", tan},
+ {"$asin", asin},
+ {"$acos", acos},
+ {"$atan", atan},
+ {"$sinh", sinh},
+ {"$cosh", cosh},
+ {"$tanh", tanh},
+ {"$asinh", lasinh},
+ {"$acosh", lacosh},
+ {"$atanh", latanh},
+ {"exact->inexact", floident},
+ {0, 0}};
+#endif
+
+#ifdef FLOATS
+# ifndef DBL_DIG
+static void add1(f, fsum)
+ double f, *fsum;
+{
+ *fsum = f + 1.0;
+}
+# endif
+#endif
+
+void init_scl()
+{
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(asubrs, tc7_asubr);
+ init_iprocs(rpsubrs, tc7_rpsubr);
+#ifdef SICP
+ add_feature("sicp");
+#endif
+#ifdef FLOATS
+ init_iprocs((iproc *)cxrs, tc7_cxr);
+ NEWCELL(flo0);
+# ifdef SINGLES
+ CAR(flo0) = tc_flo;
+ FLO(flo0) = 0.0;
+# else
+ CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real");
+ REAL(flo0) = 0.0;
+ CAR(flo0) = tc_dblr;
+# endif
+# ifdef DBL_DIG
+ dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
+# else
+ { /* determine floating point precision */
+ double f = 0.1;
+ double fsum = 1.0+f;
+ while (fsum != 1.0) {
+ f /= 10.0;
+ if (++dblprec > 20) break;
+ add1(f, &fsum);
+ }
+ dblprec = dblprec-1;
+ }
+# endif /* DBL_DIG */
+#endif
+}
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 <signal.h>
+#include "scm.h"
+#include "patchlvl.h"
+
+#ifdef __IBMC__
+# include <io.h>
+#endif
+
+#ifndef STDC_HEADERS
+ int alarm P((unsigned int));
+ int pause P((void));
+ unsigned int sleep P((unsigned int seconds));
+ char *getenv P((const char *name));
+ int system P((const char *));
+#endif
+#ifdef hpux
+# define const /**/
+#endif
+
+void final_repl P((void));
+void init_dynl P((void));
+void init_eval P((void));
+void init_features P((void));
+void init_io P((void));
+void init_ioext P((void));
+void init_repl P((int iverbose));
+void init_sc2 P((void));
+void init_scl P((void));
+void init_signals P((void));
+void init_subrs P((void));
+void init_tables P((void));
+void init_time P((void));
+void init_types P((void));
+void init_unif P((void));
+void init_ramap P((void));
+
+void init_banner()
+{
+ fputs("SCM version ", stderr);
+ fputs(SCMVERSION, stderr);
+ fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 \
+Free Software Foundation.\n\
+SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\
+This is free software, and you are welcome to redistribute it\n\
+under certain conditions; type `(terms)' for details.\n", stderr);
+}
+
+SCM scm_init_extensions()
+{
+#ifdef COMPILED_INITS
+ COMPILED_INITS; /* initialize statically linked add-ons */
+#endif
+ return UNSPECIFIED;
+}
+
+#if (__TURBOC__==1)
+# define signal ssignal /* Needed for TURBOC V1.0 */
+#endif
+
+/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/
+
+#ifdef RETSIGTYPE
+# define SIGRETTYPE RETSIGTYPE
+#else
+# ifdef STDC_HEADERS
+# if (__TURBOC__==1)
+# define SIGRETTYPE int
+# else
+# define SIGRETTYPE void
+# endif
+# else
+# ifdef linux
+# define SIGRETTYPE void
+# else
+# define SIGRETTYPE int
+# endif
+# endif
+#endif
+
+#ifdef vms
+# ifdef __GNUC__
+# define SIGRETTYPE int
+# endif
+#endif
+
+#ifdef SIGHUP
+static SIGRETTYPE hup_signal(sig)
+ int sig;
+{
+ signal(SIGHUP, hup_signal);
+ wta(UNDEFINED, (char *)HUP_SIGNAL, "");
+}
+#endif
+static SIGRETTYPE int_signal(sig)
+ int sig;
+{
+ sig = errno;
+ signal(SIGINT, int_signal);
+ if (ints_disabled) sig_deferred = 1;
+ else han_sig();
+ errno = sig;
+}
+
+/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */
+
+#ifndef SIGFPE
+# undef FLOATS
+#endif
+
+#ifdef FLOATS
+static SIGRETTYPE fpe_signal(sig)
+ int sig;
+{
+ signal(SIGFPE, fpe_signal);
+ wta(UNDEFINED, (char *)FPE_SIGNAL, "");
+}
+#endif
+#ifdef SIGBUS
+static SIGRETTYPE bus_signal(sig)
+ int sig;
+{
+ signal(SIGBUS, bus_signal);
+ wta(UNDEFINED, (char *)BUS_SIGNAL, "");
+}
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+static SIGRETTYPE segv_signal(sig)
+ int sig;
+{
+ signal(SIGSEGV, segv_signal);
+ wta(UNDEFINED, (char *)SEGV_SIGNAL, "");
+}
+#endif
+#ifdef atarist
+# undef SIGALRM /* only available via MiNT libs */
+#endif
+#ifdef GO32
+# undef SIGALRM
+#endif
+#ifdef __HIGHC__
+# undef SIGALRM
+#endif
+#ifdef SIGALRM
+static SIGRETTYPE alrm_signal(sig)
+ int sig;
+{
+ sig = errno;
+ signal(SIGALRM, alrm_signal);
+ if (ints_disabled) alrm_deferred = 1;
+ else han_alrm();
+ errno = sig;
+}
+static char s_alarm[] = "alarm";
+SCM lalarm(i)
+ SCM i;
+{
+ unsigned int j;
+ ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm);
+ SYSCALL(j = alarm(INUM(i)););
+ return MAKINUM(j);
+}
+# ifndef AMIGA
+SCM l_pause()
+{
+ pause();
+ return UNSPECIFIED;
+}
+# endif
+#endif /* SIGALRM */
+
+#ifdef _WIN32
+# include <windows.h>
+#endif
+#ifndef AMIGA
+# ifndef _Windows
+static char s_sleep[] = "sleep";
+SCM l_sleep(i)
+ SCM i;
+{
+ unsigned int j = 0;
+ ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep);
+# ifdef __HIGHC__
+ SYSCALL(sleep(INUM(i)););
+# else
+# ifdef _WIN32
+ Sleep(INUM(i));
+# else
+ SYSCALL(j = sleep(INUM(i)););
+# endif
+ return MAKINUM(j);
+}
+# endif
+# endif
+#endif
+
+#ifndef _WIN32
+# ifndef GO32
+# ifndef sun
+/* int raise P((int sig)); */
+static char s_raise[] = "raise";
+SCM l_raise(sig)
+ SCM sig;
+{
+ ASSERT(INUMP(sig), sig, ARG1, s_raise);
+# ifdef vms
+ return MAKINUM(gsignal((int)INUM(sig)));
+# else
+# ifndef __TURBOC__
+# ifdef STDC_HEADERS
+ return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T;
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
+# else
+ return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
+# endif
+# endif
+}
+# endif
+# endif
+#endif
+#ifdef TICKS
+unsigned int tick_count = 0, ticken = 0;
+SCM *loc_tick_signal;
+void tick_signal()
+{
+ if (ticken && NIMP(*loc_tick_signal)) {
+ ticken = 0;
+ apply(*loc_tick_signal, EOL, EOL);
+ }
+}
+static char s_ticks[] = "ticks";
+SCM lticks(i)
+ SCM i;
+{
+ SCM j = ticken ? tick_count : 0;
+ if (!UNBNDP(i)) ticken = tick_count = INUM(i);
+ return MAKINUM(j);
+}
+#endif
+
+#ifdef SIGHUP
+static SIGRETTYPE (*oldhup)();
+#endif
+static SIGRETTYPE (*oldint)();
+#ifdef FLOATS
+static SIGRETTYPE (*oldfpe)();
+#endif
+#ifdef SIGBUS
+static SIGRETTYPE (*oldbus)();
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+static SIGRETTYPE (*oldsegv)();
+#endif
+#ifdef SIGALRM
+static SIGRETTYPE (*oldalrm) ();
+#endif
+#ifdef SIGPIPE
+static SIGRETTYPE (*oldpipe) ();
+#endif
+
+int dumped = 0; /* Is this an invocation of unexec exe? */
+
+#ifdef SHORT_ALIGN
+typedef short STACKITEM;
+#else
+typedef long STACKITEM;
+#endif
+/* See scm.h for definition of P */
+void init_storage P((STACKITEM *stack_start_ptr, long init_heap_size));
+
+void init_scm( iverbose, buf0stdin, init_heap_size )
+ int iverbose;
+ int buf0stdin;
+ long init_heap_size;
+{
+ STACKITEM i;
+ if (2 <= iverbose) init_banner();
+ if (!dumped) {
+ init_types();
+ init_tables();
+ init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */
+ if (buf0stdin) CAR(def_inp) |= BUF0;
+ init_features();
+ init_subrs();
+ init_io();
+ init_scl();
+ init_eval();
+ init_time();
+ init_repl( iverbose );
+ init_unif();
+ }}
+
+void init_signals()
+{
+ oldint = signal(SIGINT, int_signal);
+#ifdef SIGHUP
+ oldhup = signal(SIGHUP, hup_signal);
+#endif
+#ifdef FLOATS
+ oldfpe = signal(SIGFPE, fpe_signal);
+#endif
+#ifdef SIGBUS
+ oldbus = signal(SIGBUS, bus_signal);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ oldsegv = signal(SIGSEGV, segv_signal);
+#endif
+#ifdef SIGALRM
+ alarm(0); /* kill any pending ALRM interrupts */
+ oldalrm = signal(SIGALRM, alrm_signal);
+#endif
+#ifdef SIGPIPE
+ oldpipe = signal(SIGPIPE, SIG_IGN);
+#endif
+#ifdef ultrix
+ siginterrupt(SIGINT, 1);
+ siginterrupt(SIGALRM, 1);
+ siginterrupt(SIGHUP, 1);
+ siginterrupt(SIGPIPE, 1);
+#endif /* ultrix */
+}
+
+/* This is used in preparation for a possible fork(). Ignore all
+ signals before the fork so that child will catch only if it
+ establishes a handler */
+void ignore_signals()
+{
+#ifdef ultrix
+ siginterrupt(SIGINT, 0);
+ siginterrupt(SIGALRM, 0);
+ siginterrupt(SIGHUP, 0);
+ siginterrupt(SIGPIPE, 0);
+#endif /* ultrix */
+ signal(SIGINT, SIG_IGN);
+#ifdef SIGHUP
+ signal(SIGHUP, SIG_DFL);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, SIG_DFL);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, SIG_DFL);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, SIG_DFL);
+#endif
+ /* Some documentation claims that ALRMs are cleared accross forks.
+ If this is not always true then the value returned by alarm(0)
+ will have to be saved and unignore_signals() will have to
+ reinstate it. */
+ /* This code should be neccessary only if the forked process calls
+ alarm() without establishing a handler:
+#ifdef SIGALRM
+ oldalrm = signal(SIGALRM, SIG_DFL);
+#endif */
+ /* These flushes are per warning in man page on fork(). */
+ fflush(stdout);
+ fflush(stderr);
+}
+
+void unignore_signals()
+{
+ signal(SIGINT, int_signal);
+#ifdef SIGHUP
+ signal(SIGHUP, hup_signal);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, fpe_signal);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, bus_signal);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, segv_signal);
+#endif
+#ifdef SIGALRM
+ signal(SIGALRM, alrm_signal);
+#endif
+#ifdef ultrix
+ siginterrupt(SIGINT, 1);
+ siginterrupt(SIGALRM, 1);
+ siginterrupt(SIGHUP, 1);
+ siginterrupt(SIGPIPE, 1);
+#endif /* ultrix */
+}
+
+void restore_signals()
+{
+#ifdef ultrix
+ siginterrupt(SIGINT, 0);
+ siginterrupt(SIGALRM, 0);
+ siginterrupt(SIGHUP, 0);
+ siginterrupt(SIGPIPE, 0);
+#endif /* ultrix */
+ signal(SIGINT, oldint);
+#ifdef SIGHUP
+ signal(SIGHUP, oldhup);
+#endif
+#ifdef FLOATS
+ signal(SIGFPE, oldfpe);
+#endif
+#ifdef SIGBUS
+ signal(SIGBUS, oldbus);
+#endif
+#ifdef SIGSEGV /* AMIGA lacks! */
+ signal(SIGSEGV, oldsegv);
+#endif
+#ifdef SIGPIPE
+ signal(SIGPIPE, oldpipe);
+#endif
+#ifdef SIGALRM
+ alarm(0); /* kill any pending ALRM interrupts */
+ signal(SIGALRM, oldalrm);
+#endif
+}
+
+int run_scm(argc, argv, iverbose, buf0stdin, initpath)
+ int argc;
+ char **argv;
+ int iverbose;
+ int buf0stdin;
+ char *initpath;
+{
+ SCM i;
+ do {
+ i = 0L;
+ if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) {
+ char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2];
+ do {
+ switch (*str) {
+ case DIGITS:
+ i = i * 10 + (*str - '0');
+ if (i <= 10000L) continue; /* the size limit should match Init.scm */
+ default:
+ i = 0L;
+ }
+ break;
+ } while (* ++str);
+ }
+ init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */
+ progargs = EOL;
+ progargs = makfromstrs(argc, argv);
+
+ if (!dumped) {
+#ifdef HAVE_DYNL
+ init_dynl();
+#endif
+#ifdef INITS
+ INITS; /* call initialization of extension files */
+#endif
+ }
+ init_signals();
+ i = repl_driver(initpath);
+ restore_signals();
+#ifdef TICKS
+ ticken = 0;
+#endif
+#ifdef FINALS
+ FINALS; /* call shutdown of extensions files */
+#endif /* for compatability with older modules */
+ /* call finalization of user extensions */
+ while (num_finals--) (finals[num_finals])();
+ final_repl();
+ free_storage(); /* free all allocated memory */
+ if (i) break;
+ dumped = 0;
+ if (2 <= iverbose) fputs(";RESTART\n", stderr);
+ } while (!0);
+ if (2 <= iverbose) fputs(";EXIT\n", stderr);
+ fflush(stderr);
+ return (int)INUM(i);
+}
+
+#ifdef vms
+# define SYSTNAME "vms"
+#endif
+#ifdef unix
+# define DIRSEP "/"
+# ifndef MSDOS /* DJGPP defines both */
+# define SYSTNAME "unix"
+# endif
+#endif
+#ifdef MWC
+# define SYSTNAME "coherent"
+# define DIRSEP "/"
+#endif
+#ifdef _Windows
+# define SYSTNAME "windows"
+# define DIRSEP "\\"
+#else
+# ifdef MSDOS
+# define SYSTNAME "ms-dos"
+# ifndef unix
+# define DIRSEP "\\"
+# endif
+# endif
+#endif
+#ifdef __EMX__
+# define SYSTNAME "os/2"
+# define DIRSEP "\\"
+#endif
+#ifdef __IBMC__
+# define SYSTNAME "os/2"
+# define DIRSEP "\\"
+#endif
+#ifdef THINK_C
+# define SYSTNAME "thinkc"
+# define DIRSEP ":"
+#endif
+#ifdef AMIGA
+# define SYSTNAME "amiga"
+# define DIRSEP "/"
+#endif
+#ifdef atarist
+# define SYSTNAME "atarist"
+# define DIRSEP "\\"
+#endif
+#ifdef mach
+# define SYSTNAME "mach"
+# define DIRSEP "/"
+#endif
+#ifdef ARM_ULIB
+# define SYSTNAME "acorn"
+#endif
+#ifdef nosve
+# define INIT_FILE_NAME "Init_scm";
+# define DIRSEP "."
+#endif
+
+SCM softtype()
+{
+#ifdef nosve
+ return CAR(intern("nosve", 5));
+#else
+ return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1));
+#endif
+}
+
+/* Concatentate str2 onto str1 at position n and return concatenated
+ string if file exists; 0 otherwise. */
+
+char *scm_cat_path(str1, str2, n)
+ char *str1;
+ const char *str2;
+ long n;
+{
+ if (!n) n = strlen(str2);
+ if (str1)
+ {
+ long len = strlen(str1);
+ str1 = (char *)realloc(str1, (sizet)(len + n + 1));
+ if (!str1) return 0;
+ strncat(str1 + len, str2, n);
+ return str1;
+ }
+ str1 = (char *)malloc((sizet)(n + 1));
+ if (!str1) return 0;
+ str1[0] = 0;
+ strncat(str1, str2, n);
+ return str1;
+}
+
+char *scm_try_path(path)
+ char *path;
+{
+ FILE *f;
+ /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
+ if (!path) return 0;
+ SYSCALL(f = fopen(path, "r"););
+ if (f) {
+ fclose(f);
+ return path;
+ }
+ free(path);
+ return 0;
+}
+
+char *scm_sep_init_try(path, sep, initname)
+ char *path;
+ const char *sep, *initname;
+{
+ if (path) path = scm_cat_path(path, sep, 0L);
+ if (path) path = scm_cat_path(path, initname, 0L);
+ return scm_try_path(path);
+}
+
+#ifdef MSDOS
+char *dld_find_executable(file)
+ const char *file;
+{
+ return scm_cat_path(0L, file, 0L);
+}
+#endif
+
+#ifndef INIT_FILE_NAME
+# define INIT_FILE_NAME "Init.scm"
+#endif
+#ifndef DIRSEP
+# define DIRSEP "/"
+#endif
+#ifndef GENERIC_NAME
+# define GENERIC_NAME "scm"
+#endif
+
+/* Given dld_find_executable()'s best guess for the pathname of this
+ executable, find (and verify the existence of) initname in the
+ implementation-vicinity of this program. Returns a newly allocated
+ string if successful, 0 if not */
+
+char *scm_find_impl_file(exec_path, generic_name, initname, sep)
+ char *exec_path;
+ const char *generic_name, *initname, *sep;
+{
+ char *sepptr = strrchr(exec_path, sep[0]);
+ char *extptr = exec_path + strlen(exec_path);
+ char *path = 0;
+ if (sepptr) {
+ long sepind = sepptr - exec_path + 1L;
+
+ /* In case exec_path is in the source directory, look first in
+ exec_path's directory. */
+ path = scm_cat_path(0L, exec_path, sepind - 1L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+
+#ifdef MSDOS
+ if (!strcmp(extptr - 4, ".exe") || !strcmp(extptr - 4, ".com") ||
+ !strcmp(extptr - 4, ".EXE") || !strcmp(extptr - 4, ".COM"))
+ extptr = extptr - 4;
+#endif
+
+ if (generic_name &&
+ !strncmp(exec_path + sepind, generic_name, extptr - exec_path))
+ generic_name = 0;
+
+ /* If exec_path is in directory "exe" or "bin": */
+ path = scm_cat_path(0L, exec_path, sepind - 1L);
+ sepptr = path + sepind - 4;
+ if (!strcmp(sepptr, "exe") || !strcmp(sepptr, "bin") ||
+ !strcmp(sepptr, "EXE") || !strcmp(sepptr, "BIN")) {
+ char *peer;
+
+ /* Look for initname in peer directory "lib". */
+ if (path) {
+ strncpy(sepptr, "lib", 3);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+
+ /* Look for initname in peer directories "lib" and "src" in
+ subdirectory with the name of the executable (sans any type
+ extension like .EXE). */
+ for(peer="lib";!0;peer="src") {
+ path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+ if (path) {
+ strncpy(path + sepind - 4, peer, 3);
+ path[extptr - exec_path] = 0;
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+ if (!strcmp(peer,"src")) break;
+ }
+
+ if (generic_name) {
+
+ /* Look for initname in peer directories "lib" and "src" in
+ subdirectory with the generic name. */
+ for(peer="lib";!0;peer="src") {
+ path = scm_cat_path(0L, exec_path, sepind);
+ if (path) {
+ strncpy(path + sepind - 4, "lib", 3);
+ path = scm_cat_path(path, generic_name, 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }
+ if (!strcmp(peer,"src")) break;
+ }}}
+
+#ifdef MSDOS
+ if (strlen(extptr)) {
+ /* If exec_path has type extension, look in a subdirectory with
+ the name of the executable sans the executable file's type
+ extension. */
+ path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+
+ if (generic_name) {
+
+ /* Also look in generic_name subdirectory. */
+ path = scm_cat_path(0L, exec_path, sepind);
+ if (path) path = scm_cat_path(path, generic_name, 0L);
+ path = scm_sep_init_try(path, sep, initname);
+ if (path) return path;
+ }}
+#endif
+ }
+ else {
+
+ /* We don't have a parse-able exec_path. The only path to try is
+ just initname. */
+ path = scm_cat_path(0L, initname, 0L);
+ if (path) path = scm_try_path(path);
+ if (path) return path;
+ }
+ return 0;
+}
+
+#ifndef RTL
+char *execpath = 0;
+int main( argc, argv )
+ int argc;
+ char **argv;
+{
+ int retval, buf0stdin = 0;
+ char *getenvpath, *implpath = 0;
+
+# ifndef nosve
+ getenvpath = getenv("SCM_INIT_PATH");
+ if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
+ if (implpath) {
+
+ /* The value of the environment variable supersedes other
+ locations, as long as the file exists. */
+ implpath = scm_try_path(implpath);
+ if (!implpath) {
+ fputs("Value of SCM_INIT_PATH (=\"", stderr);
+ fputs(getenvpath, stderr);
+ fputs("\") not found; Trying elsewhere\n", stderr);
+ }
+ }
+# endif
+
+ if (!implpath) {
+ execpath = dld_find_executable(argv[0]);
+ if (execpath) {
+ /* fprintf(stderr, "dld found exe \"%s\"\n", execpath); fflush(stderr); */
+ implpath = scm_find_impl_file(execpath,
+ GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
+ /* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
+ }
+# ifdef IMPLINIT
+ if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L);
+# endif
+ }
+# ifndef GO32
+ if (isatty(fileno(stdin))) {
+ buf0stdin = !0; /* stdin gets marked BUF0 in init_scm() */
+# ifndef NOSETBUF
+# ifndef _DCC
+# ifndef ultrix
+# ifndef __WATCOMC__
+# ifndef THINK_C
+# if (__TURBOC__ != 1)
+# ifndef _Windows
+ setbuf(stdin, 0); /* Often setbuf isn't actually required */
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+ }
+# endif
+# endif
+ retval = run_scm(argc, argv,
+ (isatty(fileno(stdin)) && isatty(fileno(stdout)))
+ ? (argc <= 1) ? 2 : 1 : 0,
+ buf0stdin,
+ implpath ? implpath : "");
+ if (implpath) free(implpath);
+ if (execpath) free(execpath);
+ return retval;
+}
+#endif
+
+#ifndef _Windows
+char s_system[] = "system";
+SCM lsystem(cmd)
+ SCM cmd;
+{
+ ASSERT(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system);
+ ignore_signals();
+# ifdef AZTEC_C
+ cmd = MAKINUM(Execute(CHARS(cmd), 0, 0));
+# else
+ cmd = MAKINUM(0L+system(CHARS(cmd)));
+# endif
+ unignore_signals();
+ return cmd;
+}
+#endif
+
+char s_getenv[] = "getenv";
+char *getenv();
+SCM lgetenv(nam)
+ SCM nam;
+{
+ char *val;
+ ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv);
+ val = getenv(CHARS(nam));
+ if (!val) return BOOL_F;
+ return makfrom0str(val);
+}
+
+#ifdef vms
+# include <descrip.h>
+# include <ssdef.h>
+char s_ed[] = "ed";
+SCM ed(fname)
+ SCM fname;
+{
+ struct dsc$descriptor_s d;
+ ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed);
+ d.dsc$b_dtype = DSC$K_DTYPE_T;
+ d.dsc$b_class = DSC$K_CLASS_S;
+ d.dsc$w_length = LENGTH(fname);
+ d.dsc$a_pointer = CHARS(fname);
+ /* I don't know what VMS does with signal handlers across the
+ edt$edit call. */
+ ignore_signals();
+ edt$edit(&d);
+ unignore_signals();
+ return fname;
+}
+SCM vms_debug()
+{
+ lib$signal(SS$_DEBUG);
+ return UNSPECIFIED;
+}
+#endif
+
+static iproc subr0s[] = {
+ {"software-type", softtype},
+ {"scm_init_extensions", scm_init_extensions},
+#ifdef vms
+ {"vms-debug", vms_debug},
+#endif
+#ifdef SIGALRM
+# ifndef AMIGA
+ {"pause", l_pause},
+# endif
+#endif
+ {0, 0}};
+static iproc subr1s[] = {
+ {s_getenv, lgetenv},
+#ifndef _Windows
+ {s_system, lsystem},
+#endif
+#ifdef vms
+ {s_ed, ed},
+#endif
+#ifdef SIGALRM
+ {s_alarm, lalarm},
+#endif
+#ifndef AMIGA
+# ifndef _Windows
+ {s_sleep, l_sleep},
+# endif
+#endif
+#ifndef GO32
+# ifndef sun
+# ifndef _WIN32
+ {s_raise, l_raise},
+# endif
+# endif
+#endif
+ {0, 0}};
+
+SCM *loc_features;
+void add_feature(str)
+ char* str;
+{
+ *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features);
+}
+void init_features()
+{
+ loc_features = &CDR(sysintern("*features*", EOL));
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1s, tc7_subr_1);
+#ifdef TICKS
+ loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED));
+ make_subr(s_ticks, tc7_subr_1o, lticks);
+#endif
+#ifdef RECKLESS
+ add_feature("reckless");
+#endif
+#ifndef _Windows
+ add_feature(s_system);
+#endif
+#ifdef vms
+ add_feature(s_ed);
+#endif
+ sysintern("*scm-version*", makfrom0str(SCMVERSION));
+}
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 <stdio.h>
+#include "scmfig.h"
+
+#ifdef USE_ANSI_PROTOTYPES
+# define P(s) s
+#else
+# define P(s) ()
+#endif
+
+#ifndef STDC_HEADERS
+ int isatty P((int));
+#endif
+
+typedef struct {
+ SCM (*mark)P((SCM));
+ sizet (*free)P((CELLPTR));
+ int (*print)P((SCM exp, SCM port, int writing));
+ SCM (*equalp)P((SCM, SCM));
+} smobfuns;
+
+typedef struct {
+ SCM (*mark)P((SCM ptr));
+ int (*free)P((FILE *p));
+ int (*print)P((SCM exp, SCM port, int writing));
+ SCM (*equalp)P((SCM, SCM));
+ int (*fputc)P((int c, FILE *p));
+ int (*fputs)P((char *s, FILE *p));
+ sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p));
+ int (*fflush)P((FILE *stream));
+ int (*fgetc)P((FILE *p));
+ int (*fclose)P((FILE *p));
+} ptobfuns;
+
+typedef struct {
+ SCM v;
+ sizet base;
+} array;
+typedef struct {
+ long lbnd;
+ long ubnd;
+ long inc;
+} array_dim;
+
+#ifdef FLOATS
+typedef struct {char *string;double (*cproc)P((double));} dblproc;
+# ifdef SINGLES
+# ifdef CDR_DOUBLES
+typedef struct {SCM type;double num;} flo;
+# else
+typedef struct {SCM type;float num;} flo;
+# endif
+# endif
+typedef struct {SCM type;double *real;} dbl;
+#endif
+
+#define IMP(x) (6 & (int)(x))
+#define NIMP(x) (!IMP(x))
+
+#define INUMP(x) (2 & (int)(x))
+#define NINUMP(x) (!INUMP(x))
+#define INUM0 ((SCM) 2)
+#define ICHRP(x) ((0xff & (int)(x))==0xf4)
+#define ICHR(x) ((unsigned char)((x)>>8))
+#define MAKICHR(x) (((x)<<8)+0xf4L)
+
+#define ILOCP(n) ((0xff & (int)(n))==0xfc)
+#define ILOC00 (0x000000fcL)
+#define IDINC (0x00100000L)
+#define ICDR (0x00080000L)
+#define IFRINC (0x00000100L)
+#define IDSTMSK (-IDINC)
+#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8))
+#define IDIST(n) (((unsigned long)(n))>>20)
+#define ICDRP(n) (ICDR & (n))
+
+/* ISYMP tests for ISPCSYM and ISYM */
+#define ISYMP(n) ((0x187 & (int)(n))==4)
+/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
+#define IFLAGP(n) ((0x87 & (int)(n))==4)
+#define ISYMNUM(n) ((int)((n)>>9))
+#define ISYMCHARS(n) (isymnames[ISYMNUM(n)])
+#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
+#define MAKISYM(n) (((n)<<9)+0x74L)
+#define MAKIFLAG(n) (((n)<<9)+0x174L)
+
+extern char *isymnames[];
+#define NUM_ISPCSYM 14
+#define IM_AND MAKSPCSYM(0)
+#define IM_BEGIN MAKSPCSYM(1)
+#define IM_CASE MAKSPCSYM(2)
+#define IM_COND MAKSPCSYM(3)
+#define IM_DO MAKSPCSYM(4)
+#define IM_IF MAKSPCSYM(5)
+#define IM_LAMBDA MAKSPCSYM(6)
+#define IM_LET MAKSPCSYM(7)
+#define IM_LETSTAR MAKSPCSYM(8)
+#define IM_LETREC MAKSPCSYM(9)
+#define IM_OR MAKSPCSYM(10)
+#define IM_QUOTE MAKSPCSYM(11)
+#define IM_SET MAKSPCSYM(12)
+#define IM_DEFINE MAKSPCSYM(13)
+
+#define s_and (ISYMCHARS(IM_AND)+2)
+#define s_begin (ISYMCHARS(IM_BEGIN)+2)
+#define s_case (ISYMCHARS(IM_CASE)+2)
+#define s_cond (ISYMCHARS(IM_COND)+2)
+#define s_do (ISYMCHARS(IM_DO)+2)
+#define s_if (ISYMCHARS(IM_IF)+2)
+#define s_lambda (ISYMCHARS(IM_LAMBDA)+2)
+#define s_let (ISYMCHARS(IM_LET)+2)
+#define s_letstar (ISYMCHARS(IM_LETSTAR)+2)
+#define s_letrec (ISYMCHARS(IM_LETREC)+2)
+#define s_or (ISYMCHARS(IM_OR)+2)
+#define s_quote (ISYMCHARS(IM_QUOTE)+2)
+#define s_set (ISYMCHARS(IM_SET)+2)
+#define s_define (ISYMCHARS(IM_DEFINE)+2)
+
+extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
+#define s_apply (ISYMCHARS(IM_APPLY)+2)
+
+/* each symbol defined here must have a unique number which */
+ /* corresponds to it's position in isymnames[] in sys.c */
+#define IM_APPLY MAKISYM(14)
+#define IM_CONT MAKISYM(15)
+
+#define NUM_ISYMS 16
+
+#define BOOL_F MAKIFLAG(NUM_ISYMS+0)
+#define BOOL_T MAKIFLAG(NUM_ISYMS+1)
+#define UNDEFINED MAKIFLAG(NUM_ISYMS+2)
+#define EOF_VAL MAKIFLAG(NUM_ISYMS+3)
+#ifdef SICP
+# define EOL BOOL_F
+#else
+# define EOL MAKIFLAG(NUM_ISYMS+4)
+#endif
+#define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5)
+
+/* Now some unnamed flags used as magic cookies by repl_driver. */
+/* Argument n can range from -4 to 16 */
+#ifdef SHORT_INT
+#define COOKIE(n) (n)
+#define UNCOOK(f) (f)
+#else
+#define COOKIE(n) MAKIFLAG(NUM_ISYMS+6+4+n)
+#define UNCOOK(f) (ISYMNUM(f)-(NUM_ISYMS+6+4))
+#endif
+
+#define FALSEP(x) (BOOL_F==(x))
+#define NFALSEP(x) (BOOL_F != (x))
+/* BOOL_NOT returns the other boolean. The order of ^s here is
+ important for Borland C++. */
+#define BOOL_NOT(x) ((x) ^ (BOOL_T ^ BOOL_F))
+#define NULLP(x) (EOL==(x))
+#define NNULLP(x) (EOL != (x))
+#define UNBNDP(x) (UNDEFINED==(x))
+#define CELLP(x) (!NCELLP(x))
+#define NCELLP(x) ((sizeof(cell)-1) & (int)(x))
+
+#define GCMARKP(x) (1 & (int)CDR(x))
+#define GC8MARKP(x) (0x80 & (int)CAR(x))
+#define SETGCMARK(x) CDR(x) |= 1;
+#define CLRGCMARK(x) CDR(x) &= ~1L;
+#define SETGC8MARK(x) CAR(x) |= 0x80;
+#define CLRGC8MARK(x) CAR(x) &= ~0x80L;
+#define TYP3(x) (7 & (int)CAR(x))
+#define TYP7(x) (0x7f & (int)CAR(x))
+#define TYP7S(x) (0x7d & (int)CAR(x))
+#define TYP16(x) (0xffff & (int)CAR(x))
+#define TYP16S(x) (0xfeff & (int)CAR(x))
+#define GCTYP16(x) (0xff7f & (int)CAR(x))
+
+#define NCONSP(x) (1 & (int)CAR(x))
+#define CONSP(x) (!NCONSP(x))
+#define ECONSP(x) (CONSP(x) || (1==TYP3(x)))
+#define NECONSP(x) (NCONSP(x) && (1 != TYP3(x)))
+
+#define CAR(x) (((cell *)(SCM2PTR(x)))->car)
+#define CDR(x) (((cell *)(SCM2PTR(x)))->cdr)
+#define GCCDR(x) (~1L & CDR(x))
+#define SETCDR(x, v) CDR(x) = (SCM)(v)
+
+#define CLOSUREP(x) (TYP3(x)==tc3_closure)
+#define CODE(x) (CAR(x)-tc3_closure)
+#define SETCODE(x, e) CAR(x) = (e)+tc3_closure
+#define ENV(x) CDR(x)
+
+#define PORTP(x) (TYP7(x)==tc7_port)
+#define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
+#define OPINPORTP(x) (((0x7f | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
+#define OPOUTPORTP(x) (((0x7f | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))
+#define OPIOPORTP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc7_port | OPN | RDNG | WRTNG))
+#define FPORTP(x) (TYP16S(x)==tc7_port)
+#define OPFPORTP(x) (((0xfeff | OPN) & CAR(x))==(tc7_port | OPN))
+#define OPINFPORTP(x) (((0xfeff | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
+#define OPOUTFPORTP(x) (((0xfeff | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))
+
+#define INPORTP(x) (((0x7f | RDNG) & CAR(x))==(tc7_port | RDNG))
+#define OUTPORTP(x) (((0x7f | WRTNG) & CAR(x))==(tc7_port | WRTNG))
+#define OPENP(x) (OPN & CAR(x))
+#define CLOSEDP(x) (!OPENP(x))
+#define STREAM(x) ((FILE *)(CDR(x)))
+#define SETSTREAM SETCDR
+#define CRDYP(port) (CAR(port) & CRDY)
+#define CLRDY(port) {CAR(port) &= CUC;}
+#define CGETUN(port) ((int)SRS(CAR(port), 22))
+#define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;}
+
+#define tc_socket (tc7_port | OPN)
+#define SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket))
+#define SOCKTYP(x) (CAR(x)>>24)
+
+#define DIRP(x) (NIMP(x) && (TYP16(x)==(tc16_dir)))
+#define OPDIRP(x) (NIMP(x) && (CAR(x)==(tc16_dir | OPN)))
+
+#ifdef FLOATS
+# define INEXP(x) (TYP16(x)==tc16_flo)
+# define CPLXP(x) (CAR(x)==tc_dblc)
+# define REAL(x) (*(((dbl *) (SCM2PTR(x)))->real))
+# define IMAG(x) (*((double *)(CHARS(x)+sizeof(double))))
+/* ((&REAL(x))[1]) */
+# ifdef SINGLES
+# define REALP(x) ((~REAL_PART & CAR(x))==tc_flo)
+# define SINGP(x) (CAR(x)==tc_flo)
+# define FLO(x) (((flo *)(SCM2PTR(x)))->num)
+# define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x))
+# else /* SINGLES */
+# define REALP(x) (CAR(x)==tc_dblr)
+# define REALPART REAL
+# endif /* SINGLES */
+#endif
+
+#ifdef FLOATS
+# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
+#else
+# ifdef BIGDIG
+# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
+# else
+# define NUMBERP INUMP
+# endif
+#endif
+#define NUMP(x) ((0xfcff & (int)CAR(x))==tc7_smob)
+#define BIGP(x) (TYP16S(x)==tc16_bigpos)
+#define BIGSIGN(x) (0x0100 & (int)CAR(x))
+#define BDIGITS(x) ((BIGDIG *)(CDR(x)))
+#define NUMDIGS(x) ((sizet)(CAR(x)>>16))
+#define SETNUMDIGS(x, v, t) CAR(x) = (((v)+0L)<<16)+(t)
+
+#define SNAME(x) ((CAR(x)>>8)?(SCM)(heap_org+(CAR(x)>>8)):nullstr)
+#define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc)
+#define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc)
+#define CCLO_SUBR(x) (VELTS(x)[0])
+
+#define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol)
+#define STRINGP(x) (TYP7(x)==tc7_string)
+#define NSTRINGP(x) (!STRINGP(x))
+#define VECTORP(x) (TYP7(x)==tc7_vector)
+#define NVECTORP(x) (!VECTORP(x))
+#define LENGTH(x) (((unsigned long)CAR(x))>>8)
+#define LENGTH_MAX (0xffffffL)
+#define SETLENGTH(x, v, t) CAR(x) = ((v)<<8)+(t)
+#define CHARS(x) ((char *)(CDR(x)))
+#define UCHARS(x) ((unsigned char *)(CDR(x)))
+#define VELTS(x) ((SCM *)CDR(x))
+#define SETCHARS SETCDR
+#define SETVELTS SETCDR
+
+extern long tc16_array;
+#define ARRAYP(a) (tc16_array==TYP16(a))
+#define ARRAY_V(a) (((array *)CDR(a))->v)
+/*#define ARRAY_NDIM(x) NUMDIGS(x)*/
+#define ARRAY_NDIM(x) ((sizet)(CAR(x)>>17))
+#define ARRAY_CONTIGUOUS 0x10000
+#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & (int)CAR(x))
+#define ARRAY_BASE(a) (((array *)CDR(a))->base)
+#define ARRAY_DIMS(a) ((array_dim *)(CHARS(a)+sizeof(array)))
+
+#define FREEP(x) (CAR(x)==tc_free_cell)
+#define NFREEP(x) (!FREEP(x))
+
+#define SMOBNUM(x) (0x0ff & (CAR(x)>>8));
+#define PTOBNUM(x) (0x0ff & (CAR(x)>>8));
+
+#define DIGITS '0':case '1':case '2':case '3':case '4':\
+ case '5':case '6':case '7':case '8':case '9'
+
+/* Aggregated types for dispatch in switch statements. */
+
+#define tcs_cons_imcar 2:case 4:case 6:case 10:\
+ case 12:case 14:case 18:case 20:\
+ case 22:case 26:case 28:case 30:\
+ case 34:case 36:case 38:case 42:\
+ case 44:case 46:case 50:case 52:\
+ case 54:case 58:case 60:case 62:\
+ case 66:case 68:case 70:case 74:\
+ case 76:case 78:case 82:case 84:\
+ case 86:case 90:case 92:case 94:\
+ case 98:case 100:case 102:case 106:\
+ case 108:case 110:case 114:case 116:\
+ case 118:case 122:case 124:case 126
+#define tcs_cons_nimcar 0:case 8:case 16:case 24:\
+ case 32:case 40:case 48:case 56:\
+ case 64:case 72:case 80:case 88:\
+ case 96:case 104:case 112:case 120
+#define tcs_cons_gloc 1:case 9:case 17:case 25:\
+ case 33:case 41:case 49:case 57:\
+ case 65:case 73:case 81:case 89:\
+ case 97:case 105:case 113:case 121
+
+#define tcs_closures 3:case 11:case 19:case 27:\
+ case 35:case 43:case 51:case 59:\
+ case 67:case 75:case 83:case 91:\
+ case 99:case 107:case 115:case 123
+#define tcs_subrs tc7_asubr:case tc7_subr_0:case tc7_subr_1:case tc7_cxr:\
+ case tc7_subr_3:case tc7_subr_2:case tc7_rpsubr:case tc7_subr_1o:\
+ case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr
+#define tcs_symbols tc7_ssymbol:case tc7_msymbol
+#define tcs_bignums tc16_bigpos:case tc16_bigneg
+
+#define tc3_cons 0
+#define tc3_cons_gloc 1
+#define tc3_closure 3
+
+#define tc7_ssymbol 5
+#define tc7_msymbol 7
+#define tc7_string 13
+#define tc7_vector 15
+#define tc7_bvect 21
+/* spare 23 */
+#define tc7_ivect 29
+#define tc7_uvect 31
+/* spare 37 39 */
+#define tc7_fvect 45
+#define tc7_dvect 47
+#define tc7_cvect 53
+#define tc7_port 55
+#define tc7_contin 61
+#define tc7_cclo 63
+
+/* spare 69 71 77 79 */
+#define tc7_subr_0 85
+#define tc7_subr_1 87
+#define tc7_cxr 93
+#define tc7_subr_3 95
+#define tc7_subr_2 101
+#define tc7_asubr 103
+#define tc7_subr_1o 109
+#define tc7_subr_2o 111
+#define tc7_lsubr_2 117
+#define tc7_lsubr 119
+#define tc7_rpsubr 125
+
+#define tc7_smob 127
+#define tc_free_cell 127
+
+#define tc16_flo 0x017f
+#define tc_flo 0x017fL
+
+#define REAL_PART (1L<<16)
+#define IMAG_PART (2L<<16)
+#define tc_dblr (tc16_flo|REAL_PART)
+#define tc_dblc (tc16_flo|REAL_PART|IMAG_PART)
+
+#define tc16_bigpos 0x027f
+#define tc16_bigneg 0x037f
+
+#define OPN (1L<<16)
+#define RDNG (2L<<16)
+#define WRTNG (4L<<16)
+#define BUF0 (8L<<16)
+#define CRDY (32L<<16)
+#define CUC 0x001fffffL
+
+extern sizet numsmob, numptob;
+extern smobfuns *smobs;
+extern ptobfuns *ptobs;
+extern ptobfuns pipob;
+#define tc16_fport (tc7_port + 0*256L)
+#define tc16_pipe (tc7_port + 1*256L)
+#define tc16_strport (tc7_port + 2*256L)
+#define tc16_sfport (tc7_port + 3*256L)
+extern long tc16_dir;
+
+extern SCM sys_protects[];
+#define cur_inp sys_protects[0]
+#define cur_outp sys_protects[1]
+#define cur_errp sys_protects[2]
+#define def_inp sys_protects[3]
+#define def_outp sys_protects[4]
+#define def_errp sys_protects[5]
+#define listofnull sys_protects[6]
+#define undefineds sys_protects[7]
+#define nullvect sys_protects[8]
+#define nullstr sys_protects[9]
+#define progargs sys_protects[10]
+#define transcript sys_protects[11]
+#define rootcont sys_protects[12]
+#define dynwinds sys_protects[13]
+#define stacktrace sys_protects[14]
+#ifdef FLOATS
+# define flo0 sys_protects[15]
+# define NUM_PROTECTS 16
+#else
+# define NUM_PROTECTS 15
+#endif
+
+/* now for connects between source files */
+
+extern sizet num_finals;
+extern void (**finals)P((void));
+extern unsigned char upcase[], downcase[];
+extern SCM symhash;
+extern int symhash_dim;
+extern long heap_size;
+extern CELLPTR heap_org;
+extern SCM freelist;
+extern long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
+extern long gc_syms_collected;
+extern long cells_allocated, lcells_allocated, mallocated, lmallocated;
+extern long mtrigger;
+extern SCM *loc_loadpath;
+extern SCM *loc_errobj;
+extern SCM loadport;
+extern long linum;
+extern int errjmp_bad, ints_disabled, sig_deferred, alrm_deferred;
+extern SCM exitval;
+extern int cursinit;
+extern unsigned int poll_count, tick_count;
+extern int dumped;
+extern char *execpath;
+
+/* strings used in several source files */
+
+extern char s_read[], s_write[], s_newline[], s_system[];
+extern char s_make_string[], s_make_vector[], s_list[], s_op_pipe[];
+#define s_string (s_make_string+5)
+#define s_vector (s_make_vector+5)
+#define s_pipe (s_op_pipe+5)
+extern char s_make_sh_array[];
+#define s_array (s_make_sh_array+12)
+extern char s_ccl[];
+#define s_limit (s_ccl+10)
+extern char s_close_port[];
+#define s_port_type (s_close_port+6)
+
+/* function prototypes */
+
+void gc_mark P((SCM p));
+void han_sig P((void));
+void han_alrm P((void));
+char *must_malloc P((long len, char *what));
+char *must_realloc P((char *where, long olen, long len, char *what));
+void must_free P((char *obj));
+long ilength P((SCM sx));
+SCM hash P((SCM obj, SCM n));
+SCM hashv P((SCM obj, SCM n));
+SCM hashq P((SCM obj, SCM n));
+SCM obhash P((SCM obj));
+SCM obunhash P((SCM obj));
+unsigned long strhash P((unsigned char *str, sizet len, unsigned long n));
+unsigned long hasher P((SCM obj, unsigned long n, sizet d));
+SCM repl_driver P((char *initpath));
+SCM lroom P((SCM args));
+long newsmob P((smobfuns *smob));
+long newptob P((ptobfuns *ptob));
+void prinport P((SCM exp, SCM port, char *type));
+void repl P((void));
+void growth_mon P((char *obj, long size, char *units));
+void gc_start P((char *what));
+void gc_end P((void));
+void heap_report P((void));
+void exit_report P((void));
+void stack_report P((void));
+void iprin1 P((SCM exp, SCM port, int writing));
+void intprint P((long n, int radix, SCM port));
+void iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing));
+void lputc P((int c, SCM port));
+void lputs P((char *s, SCM port));
+int lfwrite P((char *ptr, sizet size, sizet nitems, SCM port));
+int lgetc P((SCM port));
+void lungetc P((int c, SCM port));
+char *grow_tok_buf P((SCM tok_buf));
+long mode_bits P((char *modes));
+long time_in_msec P((long x));
+SCM my_time P((void));
+SCM your_time P((void));
+void init_iprocs P((iproc *subra, int type));
+void init_scm P((int iverbose, int buf0stdin, long init_heap_size));
+SCM scm_init_extensions P((void));
+void ignore_signals P((void));
+void unignore_signals P((void));
+void free_storage P((void));
+void add_feature P((char *str));
+int raprin1 P((SCM exp, SCM port, int writing));
+SCM markcdr P((SCM ptr));
+SCM mark0 P((SCM ptr));
+SCM equal0 P((SCM ptr1, SCM ptr2));
+sizet free0 P((CELLPTR ptr));
+void warn P((char *str1, char *str2));
+void everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr));
+void wta P((SCM arg, char *pos, char *s_subr));
+SCM intern P((char *name, sizet len));
+SCM sysintern P((char *name, SCM val));
+SCM sym2vcell P((SCM sym));
+SCM makstr P((long len));
+SCM make_subr P((char *name, int type, SCM (*fcn)()));
+SCM closure P((SCM code, SCM env));
+SCM makprom P((SCM code));
+SCM force P((SCM x));
+SCM makarb P((SCM name));
+SCM tryarb P((SCM arb));
+SCM relarb P((SCM arb));
+SCM ceval P((SCM x, SCM env));
+SCM prolixity P((SCM arg));
+SCM gc_for_newcell P((void));
+SCM gc P((void));
+SCM tryload P((SCM filename));
+SCM acons P((SCM w, SCM x, SCM y));
+SCM cons2 P((SCM w, SCM x, SCM y));
+SCM resizuve P((SCM vect, SCM len));
+SCM lnot P((SCM x));
+SCM booleanp P((SCM obj));
+SCM eq P((SCM x, SCM y));
+SCM equal P((SCM x, SCM y));
+SCM consp P((SCM x));
+SCM cons P((SCM x, SCM y));
+SCM nullp P((SCM x));
+SCM setcar P((SCM pair, SCM value));
+SCM setcdr P((SCM pair, SCM value));
+SCM listp P((SCM x));
+SCM list P((SCM objs));
+SCM length P((SCM x));
+SCM append P((SCM args));
+SCM reverse P((SCM lst));
+SCM list_ref P((SCM lst, SCM k));
+SCM memq P((SCM x, SCM lst));
+SCM member P((SCM x, SCM lst));
+SCM memv P((SCM x, SCM lst));
+SCM assq P((SCM x, SCM alist));
+SCM assoc P((SCM x, SCM alist));
+SCM symbolp P((SCM x));
+SCM symbol2string P((SCM s));
+SCM string2symbol P((SCM s));
+SCM numberp P((SCM x));
+SCM exactp P((SCM x));
+SCM inexactp P((SCM x));
+SCM eqp P((SCM x, SCM y));
+SCM lessp P((SCM x, SCM y));
+SCM zerop P((SCM z));
+SCM positivep P((SCM x));
+SCM negativep P((SCM x));
+SCM oddp P((SCM n));
+SCM evenp P((SCM n));
+SCM lmax P((SCM x, SCM y));
+SCM lmin P((SCM x, SCM y));
+SCM sum P((SCM x, SCM y));
+SCM difference P((SCM x, SCM y));
+SCM product P((SCM x, SCM y));
+SCM divide P((SCM x, SCM y));
+SCM lquotient P((SCM x, SCM y));
+SCM absval P((SCM x));
+SCM lremainder P((SCM x, SCM y));
+SCM modulo P((SCM x, SCM y));
+SCM lgcd P((SCM x, SCM y));
+SCM llcm P((SCM n1, SCM n2));
+SCM number2string P((SCM x, SCM radix));
+SCM istring2number P((char *str, long len, long radix));
+SCM string2number P((SCM str, SCM radix));
+SCM istr2flo P((char *str, long len, long radix));
+SCM mkbig P((sizet nlen, int sign));
+SCM mkstrport P((SCM pos, SCM str, long modes, char *caller));
+SCM long2big P((long n));
+SCM ulong2big P((unsigned long n));
+SCM big2inum P((SCM b, sizet l));
+sizet iint2str P((long num, int rad, char *p));
+SCM floequal P((SCM x, SCM y));
+SCM uve_equal P((SCM u, SCM v));
+SCM raequal P((SCM ra0, SCM ra1));
+SCM array_equal P((SCM u, SCM v));
+int rafill P((SCM ra, SCM fill, SCM ignore));
+SCM uve_fill P((SCM uve, SCM fill));
+SCM array_fill P((SCM ra, SCM fill));
+SCM array_prot P((SCM ra));
+int bigprint P((SCM exp, SCM port, int writing));
+int floprint P((SCM sexp, SCM port, int writing));
+SCM istr2int P((char *str, long len, long radix));
+SCM istr2bve P((char *str, long len));
+void ipruk P((char *hdr, SCM ptr, SCM port));
+SCM charp P((SCM x));
+SCM char_lessp P((SCM x, SCM y));
+SCM chci_eq P((SCM x, SCM y));
+SCM chci_lessp P((SCM x, SCM y));
+SCM char_alphap P((SCM chr));
+SCM char_nump P((SCM chr));
+SCM char_whitep P((SCM chr));
+SCM char_upperp P((SCM chr));
+SCM char_lowerp P((SCM chr));
+SCM char2int P((SCM chr));
+SCM int2char P((SCM n));
+SCM char_upcase P((SCM chr));
+SCM char_downcase P((SCM chr));
+SCM stringp P((SCM x));
+SCM string P((SCM chrs));
+SCM make_string P((SCM k, SCM chr));
+SCM string2list P((SCM str));
+SCM st_length P((SCM str));
+SCM st_ref P((SCM str, SCM k));
+SCM st_set P((SCM str, SCM k, SCM chr));
+SCM st_equal P((SCM s1, SCM s2));
+SCM stci_equal P((SCM s1, SCM s2));
+SCM st_lessp P((SCM s1, SCM s2));
+SCM stci_lessp P((SCM s1, SCM s2));
+SCM substring P((SCM str, SCM start, SCM end));
+SCM st_append P((SCM args));
+SCM vectorp P((SCM x));
+SCM vector_length P((SCM v));
+SCM vector P((SCM l));
+SCM vector_ref P((SCM v, SCM k));
+SCM vector_set P((SCM v, SCM k, SCM obj));
+SCM make_vector P((SCM k, SCM fill));
+SCM vector2list P((SCM v));
+SCM for_each P((SCM proc, SCM arg1, SCM args));
+SCM procedurep P((SCM obj));
+SCM apply P((SCM proc, SCM arg1, SCM args));
+SCM map P((SCM proc, SCM arg1, SCM args));
+SCM scm_make_cont P((void));
+SCM copytree P((SCM obj));
+SCM eval P((SCM obj));
+SCM input_portp P((SCM x));
+SCM output_portp P((SCM x));
+SCM cur_input_port P((void));
+SCM cur_output_port P((void));
+SCM i_setbuf0 P((SCM port));
+SCM open_file P((SCM filename, SCM modes));
+SCM open_pipe P((SCM pipestr, SCM modes));
+SCM close_port P((SCM port));
+SCM lread P((SCM port));
+SCM scm_read_char P((SCM port));
+SCM peek_char P((SCM port));
+SCM eof_objectp P((SCM x));
+SCM lwrite P((SCM obj, SCM port));
+SCM display P((SCM obj, SCM port));
+SCM newline P((SCM port));
+SCM write_char P((SCM chr, SCM port));
+SCM file_position P((SCM port));
+SCM file_set_position P((SCM port, SCM pos));
+SCM lgetenv P((SCM nam));
+SCM prog_args P((void));
+SCM makacro P((SCM code));
+SCM makmacro P((SCM code));
+SCM makmmacro P((SCM code));
+void poll_routine P((void));
+void tick_signal P((void));
+void stack_check P((void));
+SCM list2ura P((SCM ndim, SCM prot, SCM lst));
+SCM make_ra P((int ndim));
+SCM makflo P((float x));
+SCM arrayp P((SCM v, SCM prot));
+SCM array_contents P((SCM ra, SCM strict));
+SCM uve_read P((SCM v, SCM port));
+SCM uve_write P((SCM v, SCM port));
+SCM ura_read P((SCM v, SCM port));
+SCM ura_write P((SCM v, SCM port));
+SCM aset P((SCM v, SCM obj, SCM args));
+SCM aref P((SCM v, SCM args));
+SCM cvref P((SCM v, sizet pos, SCM last));
+SCM quit P((SCM n));
+void add_final P((void (*final)(void)));
+SCM makcclo P((SCM proc, long len));
+SCM make_uve P((long k, SCM prot));
+SCM ra2contig P((SCM ra, int copy));
+SCM sc2array P((SCM s, SCM ra, SCM prot));
+SCM array_copy P((SCM src, SCM dst));
+long aind P((SCM ra, SCM args, char *what));
+SCM scm_eval_string P((SCM str));
+SCM scm_load_string P((SCM str));
+void scm_print_stack P((SCM stk));
+char * dld_find_executable P((const char* command));
+SCM scm_unexec P((const SCM pathname));
+char * scm_cat_path P((char *str1, const char *str2, long n));
+
+ /* Defined in "rope.c" */
+SCM long2num P((long n));
+SCM ulong2num P((unsigned long n));
+unsigned char num2uchar P((SCM num, char *pos, char *s_caller));
+unsigned short num2ushort P((SCM num, char *pos, char *s_caller));
+unsigned long num2ulong P((SCM num, char *pos, char *s_caller));
+ long num2long P((SCM num, char *pos, char *s_caller));
+ double num2dbl P((SCM num, char *pos, char *s_caller));
+SCM makfromstr P((char *src, sizet len));
+SCM makfromstrs P((int argc, char **argv));
+SCM makfrom0str P((char *scr));
+char **makargvfrmstrs P((SCM args, char *s_v));
+void must_free_argv P((char **argv));
+SCM scm_evstr P((char *str));
+void scm_ldstr P((char *str));
+int scm_ldfile P((char *path));
+int scm_ldprog P((char *path));
+unsigned long scm_addr P((SCM args, char *name));
+
+#ifdef FLOATS
+SCM makdbl P((double x, double y));
+SCM dbl2big P((double d));
+double big2dbl P((SCM b));
+double lasinh P((double x));
+double lacosh P((double x));
+double latanh P((double x));
+double ltrunc P((double x));
+double round P((double x));
+double floident P((double x));
+#endif
+
+#ifdef BIGDIG
+void longdigs P((long x, BIGDIG digs [DIGSPERLONG ]));
+SCM adjbig P((SCM b, sizet nlen));
+SCM normbig P((SCM b));
+SCM copybig P((SCM b, int sign));
+SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny));
+SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn));
+unsigned int divbigdig P((BIGDIG *ds, sizet h, BIGDIG div));
+SCM divbigint P((SCM x, long z, int sgn, int mode));
+SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn,
+ int modes));
+long pseudolong P((long x));
+#endif
+int bigcomp P((SCM x, SCM y));
+SCM bigequal P((SCM x, SCM y));
+
+#ifdef RECKLESS
+# define ASSERT(_cond, _arg, _pos, _subr) ;
+# define ASRTGO(_cond, _label) ;
+#else
+# define ASSERT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)(_pos), _subr);
+# define ASRTGO(_cond, _label) if(!(_cond)) goto _label;
+#endif
+
+#define ARGn 0
+#define ARG1 1
+#define ARG2 2
+#define ARG3 3
+#define ARG4 4
+#define ARG5 5
+ /* following must match entry indexes in errmsgs[] */
+#define WNA 6
+#define OVFLOW 7
+#define OUTOFRANGE 8
+#define NALLOC 9
+#define EXIT 10
+#define HUP_SIGNAL 11
+#define INT_SIGNAL 12
+#define FPE_SIGNAL 13
+#define BUS_SIGNAL 14
+#define SEGV_SIGNAL 15
+#define ALRM_SIGNAL 16
+
+#define EVAL(x, env) (IMP(x)?(x):ceval((x), (env)))
+#define SIDEVAL(x, env) if NIMP(x) ceval((x), (env))
+
+#define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\
+ else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
+
+#ifdef __cplusplus
+}
+#endif
diff --git a/scm.texi b/scm.texi
new file mode 100644
index 0000000..d7270f6
--- /dev/null
+++ b/scm.texi
@@ -0,0 +1,6911 @@
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename scm.info
+@settitle SCM
+@setchapternewpage on
+@c Choices for setchapternewpage are {on,off,odd}.
+@paragraphindent 2
+@c %**end of header
+
+@iftex
+@finalout
+@c DL: lose the egregious vertical whitespace, esp. around examples
+@c but paras in @defun-like things don't have parindent
+@parskip 4pt plus 1pt
+@end iftex
+
+@titlepage
+@title SCM
+@subtitle Scheme Implementation
+@subtitle Version 4e6
+@subtitle March 1996
+@author by Aubrey Jaffer
+
+@page
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the entire
+resulting derived work is distributed under the terms of a permission
+notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation approved
+by the author.
+@end titlepage
+
+@node Top, Copying, (dir), (dir)
+
+
+@ifinfo
+This manual documents the SCM Scheme implementation. The most recent
+information about SCM can be found on SCM's @dfn{WWW} home page:
+@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html
+
+
+Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the entire
+resulting derived work is distributed under the terms of a permission
+notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation approved
+by the author.
+@end ifinfo
+
+@menu
+* Copying:: Conditions for copying and changing SCM.
+* Overview:: Whats here and how to start using it.
+* Installing SCM:: Where it goes and how to get it there.
+* The Language:: Reference.
+* Packages:: Optional Capabilities.
+* The Implementation:: How it works.
+* Procedure and Macro Index::
+* Variable Index::
+* Type Index::
+@end menu
+
+@node Copying, Overview, Top, Top
+@chapter Copying
+
+@center COPYRIGHT (c) 1989 BY
+@center PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.
+@center ALL RIGHTS RESERVED
+
+@noindent
+Permission to use, copy, modify, distribute and sell this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all copies
+and that both that copyright notice and this permission notice appear
+in supporting documentation, and that the name of Paradigm Associates
+Inc not be used in advertising or publicity pertaining to distribution
+of the software without specific, written prior permission.
+
+@noindent
+PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+@noindent
+gjc@@paradigm.com
+@flushright
+Phone: 617-492-6079
+@end flushright
+@flushleft
+Paradigm Associates Inc
+29 Putnam Ave, Suite 6
+Cambridge, MA 02138
+@end flushleft
+
+@sp 2
+
+@center Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995
+@center Free Software Foundation, Inc.
+@center 675 Mass Ave, Cambridge, MA 02139, USA
+
+@noindent
+Permission to use, copy, modify, distribute, and sell this software and
+its documentation for any purpose is hereby granted without fee,
+provided that the above copyright notice appear in all copies and that
+both that copyright notice and this permission notice appear in
+supporting documentation.
+
+@center NO WARRANTY
+
+@noindent
+BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR
+THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH
+YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+@noindent
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR
+DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL
+DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM
+(INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED
+INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF
+THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR
+OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+@node Overview, Installing SCM, Copying, Top
+@chapter Overview
+
+@noindent
+Scm is a portable Scheme implementation written in C. Scm provides a
+machine independent platform for [JACAL], a symbolic algebra system.
+
+@iftex
+@noindent
+The most recent information about SCM can be found on SCM's @dfn{WWW}
+home page:
+@ifset html
+<A HREF="http://www-swiss.ai.mit.edu/~jaffer/SCM.html">
+@end ifset
+
+@center http://www-swiss.ai.mit.edu/~jaffer/SCM.html
+
+@ifset html
+</A>
+@end ifset
+@end iftex
+
+@menu
+* SCM Features::
+* SCM Authors::
+* Bibliography::
+* Invoking SCM::
+* SCM Options::
+* SCM Variables::
+* SCM Examples::
+* SCM Session::
+* Editing Scheme Code::
+* Debugging Scheme Code::
+@end menu
+
+@node SCM Features, SCM Authors, Overview, Overview
+@section Features
+
+@itemize @bullet
+@item
+Conforms to Revised^4 Report on the Algorithmic Language Scheme [R4RS]
+and the [IEEE] P1178 specification.
+@item
+Support for [SICP], [R2RS], [R3RS], and (proposed) [R5RS] scheme code.
+@item
+Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos, VMS,
+Unix and similar systems. Supports ASCII and EBCDIC character sets.
+@item
+Is fully documented in @TeX{}info form, allowing documentation to be
+generated in info, @TeX{}, html, nroff, and troff formats.
+@item
+Supports inexact real and complex numbers, 30 bit immediate integers and
+large precision integers.
+@item
+Many Common Lisp functions: @code{logand}, @code{logor}, @code{logxor},
+@code{lognot}, @code{ash}, @code{logcount}, @code{integer-length},
+@code{bit-extract}, @code{defmacro}, @code{macroexpand},
+@code{macroexpand1}, @code{gentemp}, @code{defvar}, @code{force-output},
+@code{software-type}, @code{get-decoded-time},
+@code{get-internal-run-time}, @code{get-internal-real-time},
+@code{delete-file}, @code{rename-file}, @code{copy-tree}, @code{acons},
+and @code{eval}.
+@item
+@code{Char-code-limit}, @code{most-positive-fixnum},
+@code{most-negative-fixnum}, @code{and internal-time-units-per-second}
+constants. @code{*Features*} and @code{*load-pathname*} variables.
+@item
+Arrays and bit-vectors. String ports and software emulation ports.
+I/O extensions providing ANSI C and POSIX.1 facilities.
+@item
+Interfaces to standard libraries including REGEX string regular
+expression matching and the CURSES screen management package.
+@item
+Available add-on packages including an interactive debugger, database,
+X-window graphics, BGI graphics, Motif, and Open-Windows packages.
+@item
+A compiler (HOBBIT, available separately) and dynamic linking of
+compiled modules.
+@item
+User definable responses to interrupts and errors,
+Process-syncronization primitives. Setable levels of monitoring and
+timing information printed interactively (the @code{verbose} function).
+@code{Restart}, @code{quit}, and @code{exec}.
+@end itemize
+
+@node SCM Authors, Bibliography, SCM Features, Overview
+@section Authors
+
+@table @b
+@item Aubrey Jaffer (jaffer@@ai.mit.edu)
+Most of SCM.
+@item Radey Shouman
+Arrays. @code{gsubr}s, compiled closures, and records.
+@item Jerry D. Hedden
+Real and Complex functions. Fast mixed type arithmetics.
+@item Hugh Secker-Walker
+Syntax checking and memoization of special forms by evaluator. Storage
+allocation strategy and parameters.
+@item George Carrette
+@dfn{Siod}, written by George Carrette, was the starting point for SCM.
+The major innovations taken from Siod are the evaluator's use of the
+C-stack and being able to garbage collect off the C-stack
+(@pxref{Garbage Collection}).
+@end table
+
+@noindent
+There are many other contributors to SCM. They are acknowledged in the
+file @file{ChangeLog}, a log of changes that have been made to scm.
+
+@node Bibliography, Invoking SCM, SCM Authors, Overview
+@section Bibliography
+
+@table @asis
+@item [IEEE]
+@pindex IEEE
+@cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme
+Programming Language.} IEEE, New York, 1991.
+
+@item [Simply]
+@pindex Simply
+Brian Harvey and Matthew Wright.
+@ifset html
+<A HREF="http://HTTP.CS.Berkeley.EDU/~bh/simply-toc.html">
+@end ifset
+@cite{Simply Scheme: Introducing Computer Science}
+@ifset html
+</A>
+@end ifset
+MIT Press, 1994 ISBN 0-262-08226-8
+
+@item [SICP]
+@pindex SICP
+Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+@cite{Structure and Interpretation of Computer Programs.}
+MIT Press, Cambridge, 1985.
+
+@item [R4RS]
+@pindex R4RS
+William Clinger and Jonathan Rees, Editors.
+@ifset html
+<A HREF="r4rs_toc.html">
+@end ifset
+Revised(4) Report on the Algorithmic Language Scheme.
+@ifset html
+</A>
+@end ifset
+@cite{ACM Lisp Pointers} Volume IV, Number 3 (July-September 1991),
+pp. 1-55.
+@ifinfo
+
+@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language
+Scheme}.
+@end ifinfo
+
+@item [GUILE]
+@pindex GUILE
+Tom Lord.
+@ifset html
+<A HREF="http://www.cygnus.com/library/ctr/guile.html">
+@end ifset
+The Guile Architecture for Ubiquitous Computing.
+@ifset html
+</A>
+@end ifset
+@cite{Usenix Symposium on Tcl/Tk}, 1995.
+
+@item [SLIB]
+@pindex SLIB
+Todd R. Eigenschink, Dave Love, and Aubrey Jaffer.
+@ifset html
+<A HREF="slib_toc.html">
+@end ifset
+SLIB, The Portable Scheme Library.
+@ifset html
+</A>
+@end ifset
+Version 2a3, June 1995.
+@ifinfo
+
+@ref{Top, , , slib, SLIB}.
+@end ifinfo
+
+@item [JACAL]
+@pindex JACAL
+Aubrey Jaffer.
+@ifset html
+<A HREF="jacal_toc.html">
+@end ifset
+JACAL Symbolic Mathematics System.
+@ifset html
+</A>
+@end ifset
+Version 1a5, April 1994.
+@ifinfo
+
+@ref{Top, , , jacal, JACAL}.
+@end ifinfo
+@end table
+
+@table @file
+@item scm.texi
+@itemx scm.info
+Documentation of @code{scm} extensions (beyond Scheme standards).
+Documentation on the internal representation and how to extend or
+include @code{scm} in other programs.
+@end table
+
+@node Invoking SCM, SCM Options, Bibliography, Overview
+@section Invoking SCM
+
+@quotation
+@exdent @b{ scm } [-a @i{kbytes}] [-ibvqmu] [-p @i{number}]
+@w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-f @i{filename}]}
+@w{[-l @i{filename}]} @w{[-r @i{feature}]} @w{[-- | - | -s]}
+@w{[@i{filename}]} @w{[@i{arguments} @dots{}]}
+@end quotation
+
+@noindent
+Upon startup @code{scm} loads the file specified by by the environment
+variable @var{SCM_INIT_PATH}.
+
+@noindent
+If @var{SCM_INIT_PATH} is not defined or if the file it names is not
+present, @code{scm} tries to find the directory containing the
+executable file. If it is able to locate the executable, @code{scm}
+looks for the initialization file (usually @file{Init.scm}) in
+platform-dependent directories relative to this directory.
+@xref{File-System Habitat} for a blow-by-blow description.
+
+@noindent
+As a last resort (if initialization file cannot be located), the C
+compile parameter @var{IMPLINIT} (defined in the makefile or
+@file{scmfig.h}) is tried.
+
+@noindent
+Unless the option @code{-no-init-file} or @code{--no-init-file} occurs
+in the command line, @file{Init.scm} checks to see if there is file
+@file{ScmInit.scm} in the path specified by the environment variable
+@var{HOME} (or in the current directory if @var{HOME} is undefined). If
+it finds such a file it is loaded.
+
+@noindent
+@file{Init.scm} then looks for command input from one of three sources:
+From an option on the command line, from a file named on the command
+line, or from standard input.
+
+@noindent
+This explanation applies to SCMLIT or other builds of SCM.
+
+@noindent
+Scheme-code files can also invoke SCM and its variants. @xref{Syntax
+Extensions, #!}.
+
+@node SCM Options, SCM Variables, Invoking SCM, Overview
+@section Options
+
+@noindent
+The options are processed in the order specified on the command line.
+
+@deffn {Command Option} -a kb
+specifies that @code{scm} should allocate an initial heapsize of
+@var{kb} kilobytes. This option, if present, must be the first on
+the command line. If not specified, the default is
+@code{INIT_HEAP_SIZE} in source file @file{setjump.h} which the
+distribution sets at @code{25000*sizeof(cell)}.
+@end deffn
+
+@deffn {Command Option} -no-init-file
+@deffnx {Command Option} --no-init-file
+Inhibits the loading of @file{ScmInit.scm} as described above.
+@end deffn
+
+@deffn {Command Option} -e expression
+@deffnx {Command Option} -c expression
+specifies that the scheme expression @var{expression} is to be
+evaluated. These options are inspired by @code{perl} and @code{sh}
+respectively. On Amiga systems the entire option and argument need to be
+enclosed in quotes. For instance @samp{"-e(newline)"}.
+@end deffn
+
+@deffn {Command Option} -r feature
+requires @var{feature}. This will load a file from [SLIB] if that
+@var{feature} is not already supported. If @var{feature} is 2, 3, 4, or
+5 @code{scm} will require the features neccessary to support [R2RS],
+[R3RS], [R4RS], or proposed [R5RS], respectively.
+@end deffn
+
+@deffn {Command Option} -l filename
+@deffnx {Command Option} -f filename
+loads @var{filename}. @code{Scm} will load the first (unoptioned) file
+named on the command line if no @code{-c}, @code{-e}, @code{-f},
+@code{-l}, or @code{-s} option preceeds
+it.
+@end deffn
+
+@deffn {Command Option} -p level
+sets the prolixity (verboseness) to @var{level}. This is the same as
+the @code{scm} command (verobse @var{level}).
+@end deffn
+
+@deffn {Command Option} -v
+(verbose mode) specifies that @code{scm} will print prompts, evaluation
+times, notice of loading files, and garbage collection statistics. This
+is the same as @code{-p3}.
+@end deffn
+
+@deffn {Command Option} -q
+(quiet mode) specifies that @code{scm} will print no extra
+information. This is the same as @code{-p0}.
+@end deffn
+
+@deffn {Command Option} -m
+specifies that subsequent loads, evaluations, and user interactions will
+be with [R4RS] macro capability. To use a specific [R4RS] macro
+implementation from [SLIB] (instead of [SLIB]'s default) put @code{-r}
+@var{macropackage} before @code{-m} on the command line.
+@end deffn
+
+@deffn {Command Option} -u
+specifies that subsequent loads, evaluations, and user interactions will
+be without [R4RS] macro capability. [R4RS] macro capability can
+be restored by a subsequent @code{-m} on the command line or from Scheme
+code.
+@end deffn
+
+@deffn {Command Option} -i
+specifies that @code{scm} should run interactively. That means that
+@code{scm} will not terminate until the @code{(quit)} or @code{(exit)}
+command is given, even if there are errors. It also sets the prolixity
+level to 2 if it is less than 2. This will print prompts, evaluation
+times, and notice of loading files. The prolixity level can be set by
+subsequent options. If @code{scm} is started from a tty, it will assume
+that it should be interactive unless given a subsequent @code{-b}
+option.
+@end deffn
+
+@deffn {Command Option} -b
+specifies that @code{scm} should run non-interactively. That means that
+@code{scm} will terminate after processing the command line or if there
+are errors.
+@end deffn
+
+@deffn {Command Option} -s
+specifies, by analogy with @code{sh}, that further options are to be
+treated as program aguments.
+@end deffn
+
+@deffn {Command Option} -
+@deffnx {Command Option} --
+specifies that there are no more options on the command line.
+@end deffn
+
+@deffn {Command Option} -d filename
+loads SLIB database-utilities and opens @var{filename} as a database.
+@end deffn
+
+@deffn {Command Option} -o filename
+saves the current SCM session as the executable program @file{filename}.
+This option works only in SCM builds supporting @code{dump}
+(@pxref{Dump}).
+
+If options appear on the command line after @samp{-o @var{filename}},
+then the saved session will continue with processing those options when
+it is invoked. Otherwise the (new) command line is processed as usual
+when the saved image is invoked.
+@end deffn
+
+@deffn {Command Option} --help
+prints usage information and URL; then exit.
+@end deffn
+
+@deffn {Command Option} --version
+prints version information and exit.
+@end deffn
+
+@node SCM Variables, SCM Examples, SCM Options, Overview
+@section Environment Variables
+
+@defvr {Environment Variable} SCM_INIT_PATH
+is the pathname where @code{scm} will look for its initialization
+code. The default is the file @file{Init.scm} in the source directory.
+@end defvr
+
+@defvr {Environment Variable} SCHEME_LIBRARY_PATH
+is the [SLIB] Scheme library directory.
+@end defvr
+
+@defvr {Environment Variable} HOME
+is the directory where @file{Init.scm} will look for the user
+initialization file @file{ScmInit.scm}.
+@end defvr
+
+@section Scheme Variables
+
+@defvar *argv*
+contains the list of arguments to the program. @code{*argv*} can change
+during argument processing. This list is suitable for use as an argument
+to [SLIB] @code{getopt}.
+@end defvar
+
+@defvar *R4RS-macro*
+controls whether loading and interaction support [R4RS] macros. Define
+this in @file{ScmInit.scm} or files specified on the command line. This
+can be overridden by subsequent @code{-m} and @code{-u} options.
+@end defvar
+
+@defvar *interactive*
+controls interactivity as explained for the @code{-i} and @code{-b}
+options. Define this in @file{ScmInit.scm} or files specified on the
+command line. This can be overridden by subsequent @code{-i} and
+@code{-b} options.
+@end defvar
+
+@node SCM Examples, SCM Session, SCM Variables, Overview
+@section Examples
+
+@table @code
+@item % scm foo.scm
+Loads and executes the contents of @file{foo.scm} and then enters
+interactive session.
+
+@item % scm -f foo.scm arg1 arg2 arg3
+Parameters @code{arg1}, @code{arg2}, and @code{arg3} are stored in the
+global list @code{*argv*}; Loads and executes the contents of
+@file{foo.scm} and exits.
+
+@item % scm -s foo.scm arg1 arg2
+Sets *argv* to @code{("foo.scm" "arg1" "arg2")} and enters interactive
+session.
+
+@item % scm -e `(write (list-ref *argv* *optind*))' bar
+Prints @samp{"bar"}.
+
+@item % scm -rpretty-print -r format -i
+Loads @code{pretty-print} and @code{format} and enters interactive
+session.
+
+@item % scm -r5
+Loads @code{dynamic-wind}, @code{values}, and [R4RS] macros and enters
+interactive (with macros) session.
+
+@item % scm -r5 -r4
+Like above but @code{rev4-optional-procedures} are also loaded.
+@end table
+
+@node SCM Session, Editing Scheme Code, SCM Examples, Overview
+@section SCM Session
+
+@itemize @bullet
+@item
+Options, file loading and features can be specified from the command
+line. @xref{System interface, , , scm, SCM}. @xref{Require, , , slib,
+SLIB}.
+@item
+Typing the end-of-file character at the top level session (while SCM is
+not waiting for parenthesis closure) causes SCM to exit.
+@item
+Typing the interrupt character aborts evaluation of the current form
+and resumes the top level read-eval-print loop.
+@end itemize
+
+@node Editing Scheme Code, Debugging Scheme Code, SCM Session, Overview
+@section Editing Scheme Code
+
+@table @asis
+@item Gnu Emacs:
+Editing of Scheme code is supported by emacs. Buffers holding files
+ending in .scm are automatically put into scheme-mode.
+
+If your Emacs can run a process in a buffer you can use the Emacs
+command @samp{M-x run-scheme} with SCM. However, the run-scheme
+(@file{xscheme.el}) which comes included with Gnu Emacs 18 will work
+only with MIT Cscheme. If you are using Emacs 18, get the emacs
+packages:
+
+@ifclear html
+@itemize @bullet
+@item
+ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el
+@item
+ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el
+@end itemize
+@end ifclear
+
+@ifset html
+<A HREF="file://ftp-swiss.ai.mit.edu/pub/scheme-editor-packages/cmuscheme.el">
+ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/cmuscheme.el
+</A>
+<A HREF="file://ftp-swiss.ai.mit.edu/pub/scheme-editor-packages/comint.el">
+ftp-swiss.ai.mit.edu:/pub/scheme-editor-packages/comint.el
+</A>
+@end ifset
+
+These files are already standard in Emacs 19.
+
+If your Emacs can not run a process in a buffer, see ``under other
+systems'' below.
+
+@item Epsilon (MS-DOS):
+There is lisp (and scheme) mode available by use of the package
+@samp{LISP.E}. It offers several different indentation formats. With
+this package, buffers holding files ending in @samp{.L}, @samp{.LSP},
+@samp{.S}, and @samp{.SCM} (my modification) are automatically put into
+lisp-mode.
+
+It is possible to run a process in a buffer under Epsilon. With Epsilon
+5.0 the command line options @samp{-e512 -m0} are neccessary to manage
+RAM properly. It has been reported that when compiling SCM with Turbo
+C, you need to @samp{#define NOSETBUF} for proper operation in a process
+buffer with Epsilon 5.0.
+
+One can also call out to an editor from SCM if RAM is at a premium; See
+``under other systems'' below.
+
+@item other systems:
+Define the environment variable @samp{EDITOR} to be the name of the
+editing program you use. The SCM procedure @code{(ed arg1 @dots{})}
+will invoke your editor and return to SCM when you exit the editor. The
+following definition is convenient:
+
+@example
+(define (e) (ed "work.scm") (load "work.scm"))
+@end example
+
+Typing @samp{(e)} will invoke the editor with the file of interest.
+After editing, the modified file will be loaded.
+@end table
+
+@node Debugging Scheme Code, , Editing Scheme Code, Overview
+@section Debugging Scheme Code
+
+@noindent
+The @code{cautious} and @code{stack-limit} options of @code{build}
+(@pxref{Build Options}) support debugging in Scheme.
+
+@table @dfn
+@item CAUTIOUS
+If SCM is built with the @samp{CAUTIOUS} flag, then when an error
+occurs, a @dfn{stack trace} of certain pending calls are printed as part
+of the default error response. A (memoized) expression and newline are
+printed for each partially evaluated combination whose procedure is not
+builtin. @xref{Memoized Expressions} for how to read memoized
+expressions.
+
+Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and
+@code{user-interrupt} (invoked by @key{C-c}) to print stack traces and
+conclude by calling @code{breakpoint} (@pxref{Breakpoints, , , slib,
+SLIB}) instead of aborting to top level. Under either condition,
+program execution can be resumed by @code{(continue)}.
+
+In this configuration one can interrupt a running Scheme program with
+@key{C-c}, inspect or modify top-level values, trace or untrace
+procedures, and continue execution with @code{(continue)}.
+
+@item STACK_LIMIT
+If SCM is built with the @samp{STACK_LIMIT} flag, the interpreter will
+check stack size periodically. If the size of stack exceeds a certain
+amount (default is @code{HEAP_SEG_SIZE/2}), SCM generates a
+@code{segment violation} interrupt.
+
+The usefulness of @samp{STACK_LIMIT} depends on the user. I don't use
+it; but the user I added this feature for got primarily this type of
+error.
+@end table
+
+@noindent
+There are several SLIB macros which so useful that SCM automatically
+loads the appropriate module from SLIB if they are invoked.
+
+@defmac trace proc1 @dots{}
+Traces the top-level named procedures given as arguments.
+@defmacx trace
+With no arguments, makes sure that all the currently traced identifiers
+are traced (even if those identifiers have been redefined) and returns a
+list of the traced identifiers.
+@end defmac
+
+@defmac untrace proc1 @dots{}
+Turns tracing off for its arguments.
+@defmacx untrace
+With no arguments, untraces all currently traced identifiers and returns
+a list of these formerly traced identifiers.
+@end defmac
+
+The routine I use most for debugging is:
+
+@deffn Procedure print arg1 ...
+@code{Print} writes all its arguments, separated by spaces.
+@code{Print} outputs a @code{newline} at the end and returns the value
+of the last argument.
+
+One can just insert @samp{(print '<proc-name>} and @samp{)} around an
+expression in order to see its value as a program operates.
+@end deffn
+
+@noindent
+Sometimes more elaborate measures are needed to print values in a useful
+manner. When the values to be printed may have very large (or infinite)
+external representations, @ref{Quick Print, , , slib, SLIB}, can be
+used.
+
+When @code{trace} is not sufficient to find program flow problems,
+@ifset html
+<A HREF="http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html">
+@end ifset
+SLIB-PSD, the Portable Scheme Debugger
+@ifset html
+</A>
+@end ifset
+offers source code debugging from
+GNU Emacs. PSD runs slowly, so start by instrumenting only a few
+functions at a time.
+@lisp
+ftp-swiss.ai.mit.edu:pub/scm/slib-psd1-3.tar.gz
+prep.ai.mit.edu:pub/gnu/jacal/slib-psd1-3.tar.gz
+ftp.maths.tcd.ie:pub/bosullvn/jacal/slib-psd1-3.tar.gz
+ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz
+@end lisp
+
+
+@node Installing SCM, The Language, Overview, Top
+@chapter Installing SCM
+
+@menu
+* File-System Habitat:: All the usual suspects.
+* Executable Pathname:: Where did I come from?
+* Making SCM::
+* Building SCM::
+* SLIB:: REQUIREd reading.
+* Installing Dynamic Linking::
+* Saving Images:: Make Fast-Booting Executables
+* Automatic C Preprocessor Definitions::
+* Problems Compiling::
+* Problems Linking::
+* Problems Running::
+* Testing::
+* Reporting Problems::
+@end menu
+
+@node File-System Habitat, Executable Pathname, Installing SCM, Installing SCM
+@section File-System Habitat
+
+@noindent
+Where should software reside? Although individually a minor annoyance,
+cumulatively this question represents many thousands of frustrated user
+hours spent trying to find support files or guessing where packages need
+to be installed. Even simple programs require proper habitat; games
+need to find their score files.
+
+@noindent
+Aren't there standards for this? Some Operating Systems have devised
+regimes of software habitats -- only to have them violated by large
+software packages and imports from other OS varieties.
+
+@noindent
+In some programs, the expected locations of support files are fixed at
+time of compilation. This means that the program may not run on
+configurations unanticipated by the authors. Compiling locations into a
+program also can make it immovable -- necessitating recompilation to
+install it.
+
+@quotation
+Programs of the world unite! You have nothing to lose but loss itself.
+@end quotation
+
+@noindent
+The function @code{scm_find_impl_file} in @file{scm.c} is an attempt to
+create a utility (for inclusion in programs) which will hide the details
+of platform-dependent file habitat conventions. It takes as input the
+pathname of the executable file which is running. If there are systems
+for which this information is either not available or unrelated to the
+locations of support files, then a higher level interface will be
+needed.
+
+@deftypefun char *scm_find_impl_file(char *@var{exec_path}, char
+*@var{generic_name}, char *@var{initname}, char *@var{sep}) Given the
+pathname of this executable (@var{exec_path}), test for the existence of
+@var{initname} in the implementation-vicinity of this program. Return a
+newly allocated string of the path if successful, 0 if not. The
+@var{sep} argument is a @emph{mull-terminated string} of the character
+used to separate directory components.
+@end deftypefun
+
+@itemize @bullet
+@item
+One convention is to install the support files for an executable program
+in the same directory as the program. This possibility is tried first,
+which satisfies not only programs using this convention, but also
+uninstalled builds when testing new releases, etc.
+
+@item
+Another convention is to install the executables in a directory named
+@file{bin}, @file{BIN}, @file{exe}, or @file{EXE} and support files in a
+directroy named @file{lib}, which is a peer the executable directory.
+This arrangement allows multiple executables can be stored in a single
+directory. For example, the executable might be in
+@samp{/usr/local/bin/} and initialization file in
+@samp{/usr/local/lib/}.
+
+If the executable directory name matches, the peer directroy @file{lib}
+is tested for @var{initname}.
+
+@item
+Sometimes @file{lib} directories become too crowded. So we look in any
+subdirectories of @file{lib} or @file{src} having the name (sans type
+suffix such as @samp{.EXE}) of the program we are running. For example,
+the executable might be @samp{/usr/local/bin/foo} and initialization
+file in @samp{/usr/local/lib/foo/}.
+
+@item
+But the executable name may not be the usual program name; So also look
+in any @var{generic_name} subdirectories of @file{lib} or @file{src}
+peers.
+
+@item
+Finally, if the name of the executable file being run has a (system
+dependent) suffix which is not needed to invoke the program, then look
+in a subdirectory (of the one containing the executable file) named for
+the executable (without the suffix); And look in a @var{generic_name}
+subdirectory. For example, the executable might be
+@samp{C:\foo\bar.exe} and the initialization file in @samp{C:\foo\bar\}.
+@end itemize
+
+
+@node Executable Pathname, Making SCM, File-System Habitat, Installing SCM
+@section Executable Pathname
+
+@noindent
+When a program is executed by MS-DOS, the full pathname of that
+executable is available in @code{argv[0]}. This value can be passed to
+@code{dld_find_executable} (@pxref{File-System Habitat}).
+
+In order to find the habitat for a unix program, we first need to know
+the full pathname for the associated executable file.
+
+@deftypefun char *dld_find_executable (const char *@var{command})
+@code{dld_find_executable} returns the absolute path name of the file
+that would be executed if @var{command} were given as a command. It
+looks up the environment variable @var{PATH}, searches in each of the
+directory listed for @var{command}, and returns the absolute path name
+for the first occurrence. Thus, it is advisable to invoke
+@code{dld_init} as:
+
+@example
+main (int argc, char **argv)
+@{
+ @dots{}
+ if (dld_init (dld_find_executable (argv[0]))) @{
+ @dots{}
+ @}
+ @dots{}
+@}
+@end example
+
+@quotation
+@strong{Note:} If the current process is executed using the
+@code{execve} call without passing the correct path name as argument 0,
+@code{dld_find_executable (argv[0]) } will also fail to locate the
+executable file.
+@end quotation
+
+@code{dld_find_executable} returns zero if @code{command} is not found
+in any of the directories listed in @code{PATH}.
+@end deftypefun
+
+@node Making SCM, Building SCM, Executable Pathname, Installing SCM
+@section Making SCM
+
+The SCM distribution has @dfn{Makefile} which contains rules for making
+@dfn{scmlit}, a ``bare-bones'' version of SCM sufficient for running
+@file{build.scm}. @file{build.scm} is used to compile (or create
+scripts to compile) full featured versions.
+
+Makefiles are not portable to the majority of platforms. If
+@file{Makefile} works for you, good; If not, I don't want to hear about
+it. If you need to compile SCM without build.scm, there are several
+ways to proceed:
+
+@itemize @bullet
+@item
+Use SCM on a different platform to run @file{build.scm} to create a
+script to build SCM;
+
+@item
+Use another implementation of Scheme to run @file{build.scm} to create a
+script to build SCM;
+
+@item
+Create your own script or @file{Makefile}.
+
+@item
+Buy a SCM executable from jaffer@@ai.mit.edu. See the end of the
+@file{ANNOUNCE} file in the distribution for details.
+
+@item
+Use scmconfig (From: bos@@scrg.cs.tcd.ie):
+
+Build and install scripts using GNU @dfn{autoconf} are available from
+@file{scmconfig4e6.tar.gz} in the distribution directories. See
+@file{README.unix} in @file{scmconfig4e6.tar.gz} for further
+instructions.
+@end itemize
+
+
+@node Building SCM, SLIB, Making SCM, Installing SCM
+@section Building SCM
+
+The file @dfn{build.scm} builds and runs a relational database of how to
+compile and link SCM executables. It has information for most platforms
+which SCM has been ported to (of which I have been notified). Some of
+this information is old, incorrect, or incomplete. Send corrections and
+additions to jaffer@@ai.mit.edu.
+
+@menu
+* Invoking Build::
+* Build Options::
+@end menu
+
+@node Invoking Build, Build Options, Building SCM, Building SCM
+@subsection Invoking Build
+
+The @emph{all} method will also work for MS-DOS and unix. Use
+the @emph{all} method if you encounter problems with @file{build.scm}.
+
+@table @asis
+@item MS-DOS
+From the SCM source directory, type @samp{build} followed by up to 9
+command line arguments.
+
+@item unix
+From the SCM source directory, type @samp{build.scm} followed by command
+line arguments.
+
+@item @emph{all}
+From the SCM source directory, start @samp{scm} or @samp{scmlit} and
+type @code{(load "build.scm")}. Alternatively, start @samp{scm} or
+@samp{scmlit} with the command line argument @samp{-ilbuild}.
+
+@end table
+
+@node Build Options, , Invoking Build, Building SCM
+@subsection Build Options
+
+@noindent
+The options to @dfn{build} specify what, where, and how to build a SCM
+program or dynamically linked module. These options are unrelated to
+the SCM command line options.
+
+@deffn {Build Option} -p @var{platform-name}
+@deffnx {Build Option} ---platform=@var{platform-name}
+specifies that the compilation should be for a computer/operating-system
+combination called @var{platform-name}. @emph{Note:} The case of
+@var{platform-name} is distinguised. The current @var{platform-name}s
+are all lower-case.
+
+The platforms defined by table @dfn{platform} in @file{build.scm} are:
+@end deffn
+@example
+name processor operating-system compiler
+symbol processor-family operating-system symbol
+symbol atom symbol symbol
+================= ================= ================= =================
+*unknown* *unknown* unix *unknown*
+acorn-unixlib acorn *unknown* *unknown*
+aix powerpc aix *unknown*
+amiga-aztec m68000 amiga aztec
+amiga-dice-c m68000 amiga dice-c
+amiga-sas/c-5.10 m68000 amiga sas/c
+atari-st-gcc m68000 atari.st gcc
+atari-st-turbo-c m68000 atari.st turbo-c
+borland-c-3.1 8086 ms-dos borland-c
+djgpp i386 ms-dos gcc
+gcc *unknown* unix gcc
+highc.31 i386 ms-dos highc
+hp-ux hp-risc hp-ux *unknown*
+linux i386 linux gcc
+linux-elf i386 linux gcc
+microsoft-c 8086 ms-dos microsoft-c
+microsoft-c-nt i386 ms-dos microsoft-c
+microsoft-quick-c 8086 ms-dos microsoft-quick-c
+ms-dos 8086 ms-dos *unknown*
+os/2-cset i386 os/2 c-set++
+os/2-emx i386 os/2 gcc
+sun sparc sun-os *unknown*
+svr4 *unknown* unix *unknown*
+turbo-c-2 8086 ms-dos turbo-c
+unicos cray unicos *unknown*
+unix *unknown* unix *unknown*
+vms vax vms *unknown*
+vms-gcc vax vms gcc
+watcom-9.0 i386 ms-dos watcom
+@end example
+
+@deffn {Build Option} -o @var{filename}
+@deffnx {Build Option} ---outname=@var{filename}
+specifies that the compilation should produce an executable or object
+name of @var{filename}. The default is @samp{scm}. Executable suffixes
+will be added if neccessary, e.g. @samp{scm} @result{} @samp{scm.exe}.
+@end deffn
+
+@deffn {Build Option} -l @var{libname} @dots{}
+@deffnx {Build Option} ---libraries=@var{libname}
+specifies that the @var{libname} should be linked with the executable
+produced. If compile flags or include directories (@samp{-I}) are
+needed, they are automatically supplied for compilations. The @samp{c}
+library is always included. SCM @dfn{features} specify any libraries
+they need; so you shouldn't need this option often.
+@end deffn
+
+@deffn {Build Option} -D @var{definition} @dots{}
+@deffnx {Build Option} ---defines=@var{definition}
+specifies that the @var{definition} should be made in any C source
+compilations. If compile flags or include directories (@samp{-I}) are
+needed, they are automatically supplied for compilations. SCM
+@dfn{features} specify any flags they need; so you shouldn't need this
+option often.
+@end deffn
+
+@deffn {Build Option} ---compiler-options=@var{flag}
+specifies that that @var{flag} will be put on compiler command-lines.
+@end deffn
+
+@deffn {Build Option} ---linker-options=@var{flag}
+specifies that that @var{flag} will be put on linker command-lines.
+@end deffn
+
+@deffn {Build Option} -s @var{pathname}
+@deffnx {Build Option} ---scheme-initial=@var{pathname}
+specifies that @var{pathname} should be the default location of the SCM
+initialization file @file{Init.scm}. SCM tries several likely locations
+before resorting to @var{pathname} (@pxref{File-System Habitat}).
+If not specified, the current directory (where build is building) is
+used.
+@end deffn
+
+@deffn {Build Option} -c @var{pathname} @dots{}
+@deffnx {Build Option} ---c-source-files=@var{pathname}
+specifies that the C source files @var{pathname} @dots{} are to be
+compiled.
+@end deffn
+
+@deffn {Build Option} -j @var{pathname} @dots{}
+@deffnx {Build Option} ---object-files=@var{pathname}
+specifies that the object files @var{pathname} @dots{} are to be linked.
+@end deffn
+
+@deffn {Build Option} -i @var{call} @dots{}
+@deffnx {Build Option} ---initialization=@var{call}
+specifies that the C functions @var{call} @dots{} are to be
+invoked during initialization.
+@end deffn
+
+@deffn {Build Option} -t @var{build-what}
+@deffnx {Build Option} ---type=@var{build-what}
+specifies in general terms what sort of thing to build. The choices
+are:
+@table @samp
+@item exe
+executable program.
+@item lib
+library module.
+@item dlls
+archived dynamically linked library object files.
+@item dll
+dynamically linked library object file.
+@end table
+
+The default is to build an executable.
+@end deffn
+
+@deffn {Build Option} -h @var{batch-syntax}
+@deffnx {Build Option} --batch-dialect=@var{batch-syntax}
+specifies how to build. The default is to create a batch file for the
+host system. The SLIB file @file{batch.scm} knows how to create batch
+files for:
+@itemize @bullet
+@item
+unix
+@item
+dos
+@item
+vms
+@item
+system
+
+This option executes the compilation and linking commands through the
+use of the @code{system} procedure.
+@item
+*unknown*
+
+This option outputs Scheme code.
+@end itemize
+@end deffn
+
+@deffn {Build Option} -w @var{batch-filename}
+@deffnx {Build Option} --script-name=@var{batch-filename}
+specifies where to write the build script. The default is to display it
+on @code{(current-output-port)}.
+@end deffn
+
+@deffn {Build Option} -F @var{feature} @dots{}
+@deffnx {Build Option} ---features=@var{feature}
+specifies to build the given features into the executable. The defined
+features are:
+
+@table @dfn
+@item lit
+@itemx none
+Lightweight -- no features
+
+@item cautious
+Normally, the number of arguments arguments to interpreted closures
+ (from LAMBDA) are checked if the function part of a form is not a
+symbol or only the first time the form is executed if the function part
+is a symbol. defining @samp{reckless} disables any checking. If you
+want to have SCM always check the number of arguments to interpreted
+closures define feature @samp{cautious}.
+
+@item careful-interrupt-masking
+Define this for extra checking of interrupt masking. This is for
+debugging C code in @file{sys.c} and @file{repl.c}.
+
+@item debug
+Turns on features @samp{cautious} @samp{careful-interrupt-masking}
+@samp{stack-limit} and uses @code{-g} flags for debugging SCM source
+code.
+
+@item reckless
+If your scheme code runs without any errors you can disable almost all
+error checking by compiling all files with @samp{reckless}.
+
+@item stack-limit
+Use to enable checking for stack overflow. Define value of the C
+preprocessor variable @var{STACK_LIMIT} to be the size to which SCM
+should allow the stack to grow. STACK_LIMIT should be less than the
+maximum size the hardware can support, as not every routine checks the
+stack.
+
+@item bignums
+Large precision integers.
+
+@item arrays
+Use if you want arrays, uniform-arrays and uniform-vectors.
+
+@item array-for-each
+array-map! and array-for-each (arrays must also be defined).
+
+@item inexact
+Use if you want floating point numbers.
+
+@item engineering-notation
+Use if you want floats to display in engineering notation (exponents
+always multiples of 3) instead of scientific notation.
+
+@item single-precision-only
+Use if you want all inexact real numbers to be single precision. This
+only has an effect if SINGLES is also defined (which is the default).
+This does not affect complex numbers.
+
+@item sicp
+Use if you want to run code from:
+
+H. Abelson, G. J. Sussman, and J. Sussman,
+Structure and Interpretation of Computer Programs,
+The MIT Press, Cambridge, Massachusetts, USA
+
+@code{(eq? '() '#f)} is the major difference.
+
+@item rev2-procedures
+These procedures were specified in the @cite{Revised^2 Report on Scheme}
+but not in @cite{R4RS}.
+
+@item record
+The Record package provides a facility for user to define their own
+record data types. See SLIB for documentation.
+
+@item compiled-closure
+Use if you want to use compiled closures.
+
+@item generalized-c-arguments
+@code{make_gsubr} for arbitrary (< 11) arguments to C functions.
+
+@item tick-interrupts
+Use if you want the ticks and ticks-interrupt functions.
+
+@item i/o-extensions
+Commonly available I/O extensions: @dfn{exec}, line I/O, file
+positioning, file delete and rename, and directory functions.
+
+@item turtlegr
+@dfn{Turtle} graphics calls for both Borland-C and X11 from
+sjm@@ee.tut.fi.
+
+@item curses
+For the @dfn{curses} screen management package.
+
+@item edit-line
+interface to the editline or GNU readline library.
+
+@item regex
+String regular expression matching.
+
+@item socket
+BSD @dfn{socket} interface.
+
+@item posix
+Posix functions available on all @dfn{Unix-like} systems. fork and
+process functions, user and group IDs, file permissions, and @dfn{link}.
+
+@item unix
+Those unix features which have not made it into the Posix specs: nice,
+acct, lstat, readlink, symlink, mknod and sync.
+
+@item windows
+Microsoft Windows executable.
+
+@item dynamic-linking
+Be able to load compiled files while running.
+
+@item dump
+Convert a running scheme program into an executable file.
+
+@item heap-can-shrink
+Use if you want segments of unused heap to not be freed up after garbage
+collection. This may reduce time in GC for *very* large working sets.
+
+@item cheap-continuations
+If you only need straight stack continuations, executables compile with
+this feature will run faster and use less storage than not having it.
+Machines with unusual stacks @emph{need} this. Also, if you incorporate
+new C code into scm which uses VMS system services or library routines
+(which need to unwind the stack in an ordrly manner) you may need to
+use this feature.
+
+@item memoize-local-bindings
+Saves the interpeter from having to look up local bindings for every
+identifier reference
+
+@end table
+@end deffn
+
+@node SLIB, Installing Dynamic Linking, Building SCM, Installing SCM
+@section SLIB
+
+@noindent
+[SLIB] is a portable Scheme library meant to provide compatibility and
+utility functions for all standard Scheme implementations. Although
+SLIB is not @emph{neccessary} to run SCM, I strongly suggest you obtain
+and install it. Bug reports about running SCM without SLIB have very
+low priority. SLIB is available from the same sites as SCM:
+
+@ifclear html
+@itemize @bullet
+@item
+ftp-swiss.ai.mit.edu:/pub/scm/slib2a6.tar.gz
+@item
+prep.ai.mit.edu:/pub/gnu/jacal/slib2a6.tar.gz
+@item
+ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz
+@item
+ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2a6.tar.gz
+@end itemize
+@end ifclear
+
+@ifset html
+<A HREF="file://ftp-swiss.ai.mit.edu/pub/scm/slib2a6.tar.gz">
+ftp-swiss.ai.mit.edu:/pub/scm/slib2a6.tar.gz
+</A>
+<A HREF="file://prep.ai.mit.edu/pub/gnu/jacal/slib2a6.tar.gz">
+prep.ai.mit.edu:/pub/gnu/jacal/slib2a6.tar.gz
+</A>
+<A HREF="file://ftp.maths.tcd.ie/pub/bosullvn/jacal/slib2a6.tar.gz">
+ftp.maths.tcd.ie:pub/bosullvn/jacal/slib2a6.tar.gz
+</A>
+<A HREF="file://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2a6.tar.gz">
+ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2a6.tar.gz
+</A>
+@end ifset
+
+@noindent
+Unpack SLIB (@samp{tar xzf slib2a6.tar.gz} or @samp{unzip -ao
+slib2a6.zip}) in an appropriate directory for your system; both
+@code{tar} and @code{unzip} will create the directory @file{slib}.
+
+@noindent
+Then create a file @file{require.scm} in the SCM
+@dfn{implementation-vicinity} (this is the same directory as where the
+file @file{Init.scm} is installed). @file{require.scm} should have the
+contents:
+
+@example
+(define (library-vicinity) "/usr/local/lib/slib/")
+(load (in-vicinity (library-vicinity) "require"))
+@end example
+
+@noindent
+where the pathname string @file{/usr/local/lib/slib/} is to be replaced
+by the pathname into which you installed SLIB. Absolute pathnames are
+recommended here; if you use a relative pathname, SLIB can get confused
+when the working directory is changed (@pxref{I/O-Extensions, chmod}).
+The way to specify a relative pathname is to append it to the
+implementation-vicinity, which is absolute:
+
+@example
+(define library-vicinity
+ (let ((lv (string-append (implementation-vicinity) "../slib/")))
+ (lambda () lv)))
+(load (in-vicinity (library-vicinity) "require"))
+@end example
+
+@noindent
+Alternatively, you can set the (shell) environment variable
+@code{SCHEME_LIBRARY_PATH} to the pathname of the SLIB directory
+(@pxref{SCM Variables, SCHEME_LIBRARY_PATH, Environment Variables}). If
+set, the environment variable overrides @file{require.scm}. Again,
+absolute pathnames are recommended.
+
+
+@node Installing Dynamic Linking, Saving Images, SLIB, Installing SCM
+@section Installing Dynamic Linking
+
+@noindent
+Dynamic linking has not been ported to all platforms. Operating systems
+in the BSD family (a.out binary format) can usually be ported to
+@dfn{DLD}. The @dfn{dl} library (@code{#define SUN_DL} for SCM) was a
+proposed POSIX standard and may be available on other machines with
+@dfn{COFF} binary format. For notes about porting to MS-Windows and
+finishing the port to VMS @ref{Finishing Dynamic Linking}.
+
+@noindent
+@dfn{DLD} is a library package of C functions that performs @dfn{dynamic
+link editing} on Linux, VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0),
+SPARCstation (SunOS 4.0), Sequent Symmetry (Dynix), and Atari ST. It is
+available from:
+
+@ifclear html
+@itemize @bullet
+@item
+prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz
+@end itemize
+@end ifclear
+
+@ifset html
+<A HREF="ftp://prep.ai.mit.edu/pub/gnu/dld-3.3.tar.gz">
+prep.ai.mit.edu:pub/gnu/dld-3.3.tar.gz
+</A>
+@end ifset
+
+@noindent
+These notes about using libdl on SunOS are from @file{gcc.info}:
+
+@quotation
+On a Sun, linking using GNU CC fails to find a shared library and
+reports that the library doesn't exist at all.
+
+This happens if you are using the GNU linker, because it does only
+static linking and looks only for unshared libraries. If you have
+a shared library with no unshared counterpart, the GNU linker
+won't find anything.
+
+We hope to make a linker which supports Sun shared libraries, but
+please don't ask when it will be finished--we don't know.
+
+Sun forgot to include a static version of @file{libdl.a} with some
+versions of SunOS (mainly 4.1). This results in undefined symbols when
+linking static binaries (that is, if you use @samp{-static}). If you
+see undefined symbols @samp{_dlclose}, @samp{_dlsym} or @samp{_dlopen}
+when linking, compile and link against the file
+@file{mit/util/misc/dlsym.c} from the MIT version of X windows.
+@end quotation
+
+
+@node Saving Images, Automatic C Preprocessor Definitions, Installing Dynamic Linking, Installing SCM
+@section Saving Images
+
+@noindent
+In SCM, the ability to save running program images is called @dfn{dump}
+(@pxref{Dump}). In order to make @code{dump} available to SCM, build
+with feature @samp{dump}. @code{dump}ed executables are compatible with
+dynamic linking.
+
+@noindent
+Most of the code for @dfn{dump} is taken from
+@file{emacs-19.34/src/unex*.c}. No modifications to the emacs source
+code were required to use @file{unexelf.c}. Dump has not been ported to
+all platforms. If @file{unexec.c} or @file{unexelf.c} don't work for
+you, try using the appropriate @file{unex*.c} file from emacs.
+
+
+
+@node Automatic C Preprocessor Definitions, Problems Compiling, Saving Images, Installing SCM
+@section Automatic C Preprocessor Definitions
+
+These @samp{#defines} are automatically provided by preprocessors of
+various C compilers. SCM uses the presence or absence of these
+definitions to configure @dfn{include file} locations and aliases for
+library functions. If the definition(s) corresponding to your system
+type is missing as your system is configured, add @code{-D@var{flag}} to
+the compilation command lines or add a @code{#define @var{flag}} line to
+@file{scmfig.h} or the beginning of @file{scmfig.h}.
+
+@example
+#define Platforms:
+------- ----------
+ARM_ULIB Huw Rogers free unix library for acorn archimedes
+AZTEC_C Aztec_C 5.2a
+_DCC Dice C on AMIGA
+__GNUC__ Gnu CC (and DJGPP)
+__EMX__ Gnu C port (gcc/emx 0.8e) to OS/2 2.0
+__HIGHC__ MetaWare High C
+__IBMC__ C-Set++ on OS/2 2.1
+_MSC_VER MS VisualC++ 4.2
+MWC Mark Williams C on COHERENT
+_QC Microsoft QuickC
+__STDC__ ANSI C compliant
+__TURBOC__ Turbo C and Borland C
+__WATCOMC__ Watcom C on MS-DOS
+__ZTC__ Zortech C
+
+_AIX AIX operating system
+AMIGA SAS/C 5.10 or Dice C on AMIGA
+atarist ATARI-ST under Gnu CC
+GNUDOS DJGPP (obsolete in version 1.08)
+__GO32__ DJGPP (future?)
+hpux HP-UX
+linux Linux
+MCH_AMIGA Aztec_c 5.2a on AMIGA
+MSDOS Microsoft C 5.10 and 6.00A
+__MSDOS__ Turbo C, Borland C, and DJGPP
+nosve Control Data NOS/VE
+SVR2 System V Revision 2.
+THINK_C developement environment for the Macintosh
+ultrix VAX with ULTRIX operating system.
+unix most Unix and similar systems and DJGPP (!?)
+__unix__ Gnu CC and DJGPP
+_UNICOS Cray operating system
+_Windows Borland C 3.1 compiling for Windows
+_WIN32 MS VisualC++ 4.2 under Windows-NT
+vms (and VMS) VAX-11 C under VMS.
+
+hp9000s800 HP RISC processor
+__i386__ DJGPP
+i386 DJGPP
+MULTIMAX Encore computer
+pyr Pyramid 9810 processor
+sparc SPARC processor
+sequent Sequent computer
+tahoe CCI Tahoe processor
+@end example
+
+@node Problems Compiling, Problems Linking, Automatic C Preprocessor Definitions, Installing SCM
+@section Problems Compiling
+
+@table @asis
+@item FILE: PROBLEM
+HOW TO FIX
+@item *.c: include file not found
+Correct the status of STDC_HEADERS in @file{scmfig.h}
+
+fix #include statement or add #define for system type to
+@file{scmfig.h}.
+@item *.c: Function should return a value in @dots{}
+@itemx *.c: Parameter '@dots{}' is never used in @dots{}
+@itemx *.c: Condition is always false in @dots{}
+@itemx *.c: Unreachable code in function @dots{}
+Ignore.
+@item scm.c: assignment between incompatible types
+change SIGRETTYPE in @file{scm.c}.
+@item time.c: CLK_TCK redefined
+incompatablility between <stdlib.h> and <sys/types.h>. remove
+STDC_HEADERS in @file{scmfig.h}.
+
+edit <sys/types.h> to remove incompatability.
+@item subr.c: Possibly incorrect assignment in function lgcd
+Ignore.
+@item sys.c: statement not reached
+@itemx sys.c: constant in conditional expression
+ignore
+@item sys.c: `???' undeclared, outside of functions
+#undef STDC_HEADERS in @file{scmfig.h}.
+@item scl.c: syntax error
+#define SYSTNAME to your system type in @file{scl.c} (softtype)
+@end table
+
+@node Problems Linking, Problems Running, Problems Compiling, Installing SCM
+@section Problems Linking
+
+@table @asis
+@item PROBLEM
+HOW TO FIX
+@item _sin etc. missing.
+uncomment LIBS in makefile
+@end table
+
+@node Problems Running, Testing, Problems Linking, Installing SCM
+@section Problems Running
+
+@table @asis
+@item PROBLEM
+HOW TO FIX
+@item Opening message and then machine crashes.
+Change memory model option to C compiler (or makefile).
+
+Make sure @code{sizet} definition is correct in @file{scmfig.h}.
+
+Reduce size of HEAP_SEG_SIZE in @file{setjump.h}.
+@item Input hangs
+#define NOSETBUF
+@item ERROR: heap: need larger initial
+Need to increase the initial heap allocation using -a<kb> or
+INIT_HEAP_SIZE.
+@item ERROR: Could not allocate @dots{}
+Check @code{sizet} definition.
+
+Use 32 bit compiler mode.
+
+Don't try to run as subproccess
+@item remove @dots{} in scmfig.h and recompile scm
+@itemx add @dots{} in scmfig.h and recompile scm
+Do it and recompile files.
+@item ERROR: @file{Init.scm} not found
+Assign correct IMPLINIT in makefile or @file{scmfig.h} or define
+environment variable @code{SCM_INIT_PATH} to be the full pathname of
+@file{Init.scm} (@pxref{Installing SCM}).
+@item WARNING: require.scm not found
+define environment variable @code{SCHEME_LIBRARY_PATH} to be the full
+pathname of the scheme library [SLIB] or change @code{library-vicinity} in
+@file{Init.scm} to point to library or remove. @xref{Installation, , , slib,
+SLIB}.
+
+Make sure the value of @code{(library-vicinity)} has a trailing file
+separator (like @key{/} or @key{\}).
+@end table
+
+@node Testing, Reporting Problems, Problems Running, Installing SCM
+@section Testing
+
+@noindent
+Loading @file{r4rstest.scm} in the distribution will run an [R4RS]
+conformance test on @code{scm}.
+
+@example
+> (load "r4rstest.scm")
+@print{}
+;loading "r4rstest.scm"
+SECTION(2 1)
+SECTION(3 4)
+ #<primitive-procedure boolean?>
+ #<primitive-procedure char?>
+ #<primitive-procedure null?>
+ #<primitive-procedure number?>
+@dots{}
+@end example
+
+@noindent
+Loading @file{pi.scm} in the distribution will enable you to compute
+digits of pi.
+
+@example
+> (load "pi")
+;loading "pi"
+;done loading "pi.scm"
+;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other
+#<unspecified>
+> (pi 100 5)
+00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
+37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
+70679
+;Evaluation took 550 mSec (60 in gc) 36976 cells work, 1548 bytes other
+#<unspecified>
+@end example
+
+@noindent
+Loading @file{bench.scm} will compute and display performance statistics
+of SCM running @file{pi.scm}. @samp{make bench} or @samp{make benchlit}
+appends the performance report to the file @file{BenchLog}, facilitating
+tracking effects of changes to SCM on performance.
+
+@table @asis
+@item PROBLEM
+HOW TO FIX
+@item Runs some and then machine crashes.
+See above under machine crashes.
+@item Runs some and then ERROR: @dots{} (after a GC has happened)
+Remove optimization option to C compiler and recompile.
+
+@code{#define SHORT_ALIGN} in @file{scmfig.h}.
+@item Some symbol names print incorrectly.
+Change memory model option to C compiler (or makefile).
+
+Check that @code{HEAP_SEG_SIZE} fits within @code{sizet}.
+
+Increase size of @code{HEAP_SEG_SIZE} (or @code{INIT_HEAP_SIZE} if it is
+smaller than @code{HEAP_SEG_SIZE}).
+@item ERROR: Rogue pointer in Heap.
+See above under machine crashes.
+@item Newlines don't appear correctly in output files.
+Check file mode (define OPEN_@dots{} in @file{Init.scm}
+@item Spaces or control characters appear in symbol names
+Check character defines in @file{scmfig.h}.
+@item Negative numbers turn positive.
+Check SRS in @file{scmfig.h}.
+@item VMS: Couldn't unwind stack
+@itemx VAX: botched longjmp
+@code{#define CHEAP_CONTIUATIONS} in @file{scmfig.h}.
+@item Sparc(SUN-4) heap is growing out of control
+You are experiencing a GC problem peculiar to the Sparc. The problem is
+that SCM doesn't know how to clear register windows. Every location
+which is not reused still gets marked at GC time. This causes lots of
+stuff which should be collected to not be. This will be a problem with
+any @emph{conservative} GC until we find what instruction will clear the
+register windows. This problem is exacerbated by using lots of
+call-with-current-continuations.
+@end table
+
+@node Reporting Problems, , Testing, Installing SCM
+@section Reporting Problems
+
+@noindent
+Reported problems and solutions are grouped under Compiling, Linking,
+Running, and Testing. If you don't find your problem listed there, you
+can send a bug report to @code{jaffer@@ai.mit.edu}. The bug report
+should include:
+
+@enumerate
+@item
+The version of SCM (printed when SCM is invoked with no arguments).
+@item
+The type of computer you are using.
+@item
+The name and version of your computer's operating system.
+@item
+The values of the environment variables @code{SCM_INIT_PATH} and
+@code{SCHEME_LIBRARY_PATH}.
+@item
+The name and version of your C compiler.
+@item
+If you are using an executable from a distribution, the name, vendor,
+and date of that distribution. In this case, corresponding with the
+vendor is recommended.
+@end enumerate
+
+@node The Language, Packages, Installing SCM, Top
+@chapter The Language
+
+This section describes features which are either present in all builds
+of SCM or which must be enabled when SCM is compiled.
+
+@menu
+* Standards Compliance:: Links to sections in [R4RS] and [SLIB]
+* System Interface:: Like how to exit
+* Errors::
+* Memoized Expressions:: What #@@0+1 and #@@? mean
+* Internal State:: GC, errors, and diagnostics
+* Miscellaneous Procedures::
+* Time:: Both real time and processor time
+* Interrupts:: and exceptions
+* Process Synchronization:: Because interrupts are preemptive
+* Files and Ports::
+* Soft Ports:: Emulate I/O devices
+* Syntax Extensions:: and how to Define New Syntax
+* Low Level Syntactic Hooks::
+@end menu
+
+@node Standards Compliance, System Interface, The Language, The Language
+@section Standards Compliance
+
+@noindent
+Scm conforms to the
+@ifset html
+[IEEE],
+@end ifset
+@cite{IEEE Standard 1178-1990. IEEE Standard for the Scheme Programming
+Language.}
+@ifclear html
+(@pxref{Bibliography}),
+@end ifclear
+and
+@ifset html
+[R4RS], <A HREF="r4rs_toc.html">
+@end ifset
+@cite{Revised(4) Report on the Algorithmic Language Scheme}.
+@ifset html
+</A>
+@end ifset
+@ifinfo
+@ref{Top, , , r4rs, Revised(4) Report on the Algorithmic Language
+Scheme}.
+@end ifinfo
+All the required features of these specifications are supported.
+Many of the optional features are supported as well.
+
+@subheading Optionals of [R4RS] Supported by SCM
+
+@table @asis
+@item two clause @code{if}: @code{(if <test> <consequent>)}
+@xref{Conditionals, , , r4rs, Revised(4) Scheme}.
+@item @code{let*}
+@itemx named @code{let}
+@xref{Binding constructs, , , r4rs, Revised(4) Scheme}.
+@item @code{do}
+@xref{Iteration, , , r4rs, Revised(4) Scheme}.
+@item All varieties of @code{define}
+@xref{Definitions, , , r4rs, Revised(4) Scheme}.
+@item @code{list-tail}
+@xref{Pairs and lists, , , r4rs, Revised(4) Scheme}.
+@item @code{string-copy}
+@itemx @code{string-fill!}
+@xref{Strings, , , r4rs, Revised(4) Scheme}.
+@item @code{make-vector} of two arguments
+@itemx @code{vector-fill!}
+@xref{Vectors, , , r4rs, Revised(4) Scheme}.
+@item @code{apply} of more than 2 arguments
+@xref{Control features, , , r4rs, Revised(4) Scheme}.
+@item @code{-} and @code{/} of more than 2 arguments
+@itemx @code{exp}
+@itemx @code{log}
+@itemx @code{sin}
+@itemx @code{cos}
+@itemx @code{tan}
+@itemx @code{asin}
+@itemx @code{acos}
+@itemx @code{atan}
+@itemx @code{sqrt}
+@itemx @code{expt}
+@itemx @code{make-rectangular}
+@itemx @code{make-polar}
+@itemx @code{real-part}
+@itemx @code{imag-part}
+@itemx @code{magnitude}
+@itemx @code{angle}
+@itemx @code{exact->inexact}
+@itemx @code{inexact->exact}
+@xref{Numerical operations, , , r4rs, Revised(4) Scheme}.
+@item @code{delay}
+@itemx @code{force}
+@xref{Control features, , , r4rs, Revised(4) Scheme}.
+@itemx @code{with-input-from-file}
+@itemx @code{with-output-to-file}
+@xref{Ports, , , r4rs, Revised(4) Scheme}.
+@itemx @code{char-ready?}
+@xref{Input, , , r4rs, Revised(4) Scheme}.
+@itemx @code{transcript-on}
+@itemx @code{transcript-off}
+@xref{System interface, , , r4rs, Revised(4) Scheme}.
+@end table
+
+@subheading Optionals of [R4RS] not Supported by SCM
+
+@table @asis
+@item @code{numerator}
+@itemx @code{denominator}
+@itemx @code{rationalize}
+@xref{Numerical operations, , , r4rs, Revised(4) Scheme}.
+@item [R4RS] appendix Macros
+@xref{Macros, , , r4rs, Revised(4) Scheme}.
+@end table
+
+@subheading [SLIB] Features of SCM and SCMLIT
+
+@table @code
+@item delay
+@itemx full-continuation
+@itemx ieee-p1178
+@itemx object-hash
+@itemx rev4-report
+@itemx source
+See SLIB file @file{Template.scm}.
+@item current-time
+@xref{Time, , , slib, SLIB}.
+@item defmacro
+@xref{Defmacro, , , slib, SLIB}.
+@item dynamic-wind
+@xref{Dynamic-Wind, , , slib, SLIB}.
+@item eval
+@xref{System, , , slib, SLIB}.
+@item getenv
+@itemx system
+@xref{System Interface, , , slib, SLIB}.
+@item hash
+@xref{Hashing, , , slib, SLIB}.
+@item logical
+@xref{Bit-Twiddling, , , slib, SLIB}.
+@item multiarg-apply
+@xref{Multi-argument Apply, , , slib, SLIB}.
+@item multiarg/and-
+@xref{Multi-argument / and -, , , slib, SLIB}.
+@item rev4-optional-procedures
+@xref{Rev4 Optional Procedures, , , slib, SLIB}.
+@item string-port
+@xref{String Ports, , , slib, SLIB}.
+@item tmpnam
+@xref{Input/Output, , , slib, SLIB}.
+@item transcript
+@xref{Transcripts, , , slib, SLIB}.
+@item vicinity
+@xref{Vicinity, , , slib, SLIB}.
+@item with-file
+@xref{With-File, , , slib, SLIB}.
+@end table
+
+@subheading [SLIB] Features of SCM
+
+@table @code
+@item array
+@xref{Arrays, , , slib, SLIB}.
+@item array-for-each
+@xref{Array Mapping, , , slib, SLIB}.
+@item bignum
+@itemx complex
+@itemx inexact
+@itemx rational
+@itemx real
+@xref{Require, , , slib, SLIB}.
+@end table
+
+@node System Interface, Errors, Standards Compliance, The Language
+@section System Interface
+
+@noindent
+For documentation of the procedures @code{getenv} and @code{system}
+@xref{System Interface, , , slib, SLIB}.
+
+@defun quit
+@defunx quit n
+@defunx exit
+@defunx exit n
+Aliases for @code{exit} (@pxref{System, exit, , slib, SLIB}). On many
+systems, SCM can also tail-call another program. @xref{I/O-Extensions,
+execp}.
+@end defun
+
+@defun vms-debug
+If SCM is compiled under VMS these commands will invoke the editor or
+debugger respectively.
+@end defun
+
+@defun ed filename
+If SCM is compiled under VMS @code{ed} will invoke the editor with a
+single the single argument @var{filename}.
+
+@defunx ed arg1 @dots{}
+Otherwise, the value of the environment variable @code{EDITOR} (or just
+@code{ed} if it isn't defined) is invoked as a command with arguments
+@var{arg1} @dots{}.
+@end defun
+
+@defun program-arguments
+Returns a list of strings of the arguments scm was called with.
+@end defun
+
+@defun errno
+@defunx errno n
+With no argument returns the current value of the system variable
+@code{errno}. When given an argument, @code{errno} sets the system
+variable @code{errno} to @var{n} and returns the previous value of
+@code{errno}. @code{(errno 0)} will clear outstanding errors. This is
+recommended after @code{try-load} returns @code{#f} since this occurs
+when the file could not be opened.
+@end defun
+
+@defun perror string
+Prints on standard error output the argument @var{string}, a colon,
+followed by a space, the error message corresponding to the current
+value of @code{errno} and a newline. The value returned is unspecified.
+@end defun
+
+@node Errors, Memoized Expressions, System Interface, The Language
+@section Errors
+
+@noindent
+A computer-language implementation designer faces choices of how
+reflexive to make the implementation in handling exceptions and errors;
+that is, how much of the error and exception routines should be written
+in the language itself. The design of a portable implementation is
+further constrained by the need to have (almost) all errors print
+meaningful messages, even when the implementation itself is not
+functioning correctly. Therefore, SCM implements much of its error
+response code in C.
+
+@noindent
+The following common error and conditions are handled by C code. Those
+with callback names after them can also be handled by Scheme code
+(@pxref{Interrupts}). If the callback identifier is not defined at top
+level, the default error handler (C code) is invoked. There are many
+other error messages which are not treated specially.
+
+@enumerate 0
+@item
+Wrong type in arg 0
+@item
+Wrong type in arg 1
+@item
+Wrong type in arg 2
+@item
+Wrong type in arg 3
+@item
+Wrong type in arg 4
+@item
+Wrong type in arg 5
+@item
+Wrong number of args
+@item
+numerical overflow
+@item
+Argument out of range
+@item
+Could not allocate @code{(out-of-storage)}
+@item
+EXIT @code{(end-of-program)}
+@item
+hang up @code{(hang-up)}
+@item
+user interrupt @code{(user-interrupt)}
+@item
+arithmetic error @code{(arithmetic-error)}
+@item
+bus error
+@item
+segment violation
+@item
+alarm @code{(alarm-interrupt)}
+@end enumerate
+
+@defvar errobj
+If SCM encounters a non-fatal error it aborts evaluation of the current
+form, prints a message explaining the error, and resumes the top level
+read-eval-print loop. The value of @var{errobj} is the offending object
+if appropriate. The builtin procedure @code{error} does @emph{not} set
+@var{errobj}.
+@end defvar
+
+@defun error arg1 arg2 arg3 @dots{}
+Alias for @ref{System, error, , slib, SLIB}. Outputs an error message
+containing the arguments, aborts evaluation of the current form and
+resumes the top level read-eval-print loop. Error is defined in
+@file{Init.scm}; Feel free to redefine it to suit your purposes.
+@end defun
+
+@subsection CAUTIOUS enhancements
+
+@noindent
+If SCM is built with the @samp{CAUTIOUS} flag, then when an error
+occurs, a @dfn{stack trace} of certain pending calls are printed as part
+of the default error response. A (memoized) expression and newline are
+printed for each partially evaluated combination whose procedure is not
+builtin. @xref{Memoized Expressions} for how to read memoized
+expressions.
+
+@noindent
+Also as the result of the @samp{CAUTIOUS} flag, both @code{error} and
+@code{user-interrupt} (invoked by @key{C-c}) are defined to print stack
+traces and conclude by calling @code{breakpoint} (@pxref{Breakpoints, ,
+, slib, SLIB}). This allows the user to interract with SCM as with Lisp
+systems.
+
+@defun stack-trace
+Prints information describing the stack of partially evaluated
+expressions. @code{stack-trace} returns @code{#t} if any lines were
+printed and @code{#f} otherwise. See @file{Init.scm} for an example of
+the use of @code{stack-trace}.
+@end defun
+
+@node Memoized Expressions, Internal State, Errors, The Language
+@section Memoized Expressions
+
+@noindent
+SCM memoizes the address of each occurence of an identifier's value when
+first encountering it in a source expression. Subsequent executions of
+that memoized expression is faster because the memoized reference
+encodes where in the top-level or local environment its value is.
+
+@noindent
+When procedures are displayed, the memoized locations appear in a format
+different from references which have not yet been executed. I find this
+a convenient aid to locating bugs and untested expressions.
+
+@itemize @bullet
+@item
+The names of memoized lexically bound identifiers are replaced with
+@r{#@@}@i{<m>}@r{-}@i{<n>}, where @i{<m>} is the number of binding
+contours back and @i{<n>} is the index of the value in that
+binding countour.
+@item
+The names of identifiers which are not lexiallly bound but defined at
+top-level have @r{#@@} prepended.
+@end itemize
+
+@noindent
+For instance, @code{open-input-file} is defined as follows in
+@file{Init.scm}:
+
+@example
+(define (open-input-file str)
+ (or (open-file str OPEN_READ)
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "OPEN-INPUT-FILE couldn't open file " str)))
+@end example
+
+@noindent
+If @code{open-input-file} has not yet been used, the displayed procedure
+is similar to the original definition (lines wrapped for readability):
+
+@example
+open-input-file @result{}
+#<CLOSURE (str) (or (open-file str open_read)
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "OPEN-INPUT-FILE couldn't open file " str))>
+@end example
+
+@noindent
+If we open a file using @code{open-input-file}, the sections of code
+used become memoized:
+
+@example
+(open-input-file "r4rstest.scm") @result{} #<input-port 3>
+open-input-file @result{}
+#<CLOSURE (str) (#@@or (#@@open-file #@@0+0 #@@open_read)
+ (and (procedure? could-not-open) (could-not-open) #f)
+ (error "OPEN-INPUT-FILE couldn't open file " str))>
+@end example
+
+@noindent
+If we cause @code{open-input-file} to execute other sections of code,
+they too become memoized:
+
+@example
+(open-input-file "foo.scm") @result{}
+
+ERROR: No such file or directory
+ERROR: OPEN-INPUT-FILE couldn't open file "foo.scm"
+
+open-input-file @result{}
+#<CLOSURE (str) (#@@or (#@@open-file #@@0+0 #@@open_read)
+ (#@@and (#@@procedure? #@@could-not-open) (could-not-open) #f)
+ (#@@error "OPEN-INPUT-FILE couldn't open file " #@@0+0))>
+@end example
+
+
+@node Internal State, Miscellaneous Procedures, Memoized Expressions, The Language
+@section Internal State
+
+@defvar *interactive*
+The variable @var{*interactive*} determines whether the SCM session is
+interactive, or should quit after the command line is processed.
+@var{*interactive*} is controlled directly by the command-line options
+@samp{-b}, @samp{-i}, and @samp{-s} (@pxref{Invoking SCM}). If none of
+these options are specified, the rules to determine interactivity are
+more complicated; see @file{Init.scm} for details.
+@end defvar
+
+@defun abort
+Resumes the top level Read-Eval-Print loop.
+@end defun
+
+@defun restart
+Restarts the SCM program with the same arguments as it was originally
+invoked. All @samp{-l} loaded files are loaded again; If those files
+have changed, those changes will be reflected in the new session.
+
+@emph{Note:} When running a saved executable (@pxref{Dump}),
+@code{restart} is redefined to be @code{exec-self}.
+@end defun
+
+@defun exec-self
+Exits and immediately re-invokes the same executable with the same
+arguments. If the executable file has been changed or replaced since
+the beginning of the current session, the @emph{new} executable will be
+invoked. This differentiates @code{exec-self} from @code{restart}.
+@end defun
+
+@defun verbose n
+Controls how much monitoring information is printed.
+If @var{n} is:
+
+@table @asis
+@item 0
+no prompt or information is printed.
+@item >= 1
+a prompt is printed.
+@item >= 2
+the CPU time is printed after each top level form evaluated.
+@item >= 3
+messages about heap growth are printed.
+@item >= 4
+garbage collection (@pxref{Garbage Collection}) messages are printed.
+@item >= 5
+a warning will be printed for each top-level symbol which is defined
+more than one time.
+@end table
+@end defun
+
+@defun gc
+Scans all of SCM objects and reclaims for further use those that are
+no longer accessible.
+@end defun
+
+@defun room
+@defunx room #t
+Prints out statistics about SCM's current use of storage. @code{(room #t)}
+also gives the hexadecimal heap segment and stack bounds.
+@end defun
+
+@defvr Constant *scm-version*
+Contains the version string (e.g. @file{4e6}) of SCM.
+@end defvr
+
+@noindent
+For other configuration constants and procedures @xref{Configuration, ,
+, slib, SLIB}.
+
+@node Miscellaneous Procedures, Time, Internal State, The Language
+@section Miscellaneous Procedures
+
+@defun try-load filename
+If the string @var{filename} names an existing file, the try-load
+procedure reads Scheme source code expressions and definitions from the
+file and evaluates them sequentially and returns @code{#t}. If not,
+try-load returns @code{#f}. The try-load procedure does not affect the
+values returned by @code{current-input-port} and
+@code{current-output-port}.
+@end defun
+
+@defvar *load-pathname*
+Is set to the pathname given as argument to @code{load},
+@code{try-load}, and @code{dyn:link} (@pxref{Compiling And Linking}).
+@code{*load-pathname*} is used to compute the value of @ref{Vicinity,
+program-vicinity, , slib, SLIB}.
+@end defvar
+
+@defun line-number
+Returns the current line number of the file currently being loaded.
+@end defun
+
+@defun eval obj
+Alias for @ref{System, eval, , slib, SLIB}.
+@end defun
+
+@defun eval-string str
+Returns the result of reading an expression from @var{str} and
+evaluating it. @code{eval-string} does not change
+@code{*load-pathname*} or @code{line-number}.
+@end defun
+
+@defun load-string str
+Reads and evaluates all the expressions from @var{str}. As with
+@code{load}, the value returned is unspecified. @code{eval-string} does
+not change @code{*load-pathname*} or @code{line-number}.
+@end defun
+
+@defun vector-set-length! object length
+Change the length of string, vector, bit-vector, or uniform-array
+@var{object} to @var{length}. If this shortens @var{object} then the
+remaining contents are lost. If it enlarges @var{object} then the
+contents of the extended part are undefined but the original part is
+unchanged. It is an error to change the length of literal datums. The
+new object is returned.
+@end defun
+
+@defun copy-tree obj
+@xref{Tree Operations, copy-tree, , slib, SLIB}. This extends the SLIB
+version by also copying vectors.
+@end defun
+
+@defun acons obj1 obj2 obj3
+Returns (cons (cons obj1 obj2) obj3). The expression (set! a-list
+(acons key datum a-list)) adds a new association to a-list.
+@end defun
+
+@defun terms
+This command displays the GNU General Public License.
+@end defun
+
+@defun list-file filename
+Displays the text contents of @var{filename}.
+@end defun
+
+@deffn Procedure print arg1 ...
+@code{Print} writes all its arguments, separated by spaces.
+@code{Print} outputs a @code{newline} at the end and returns the value
+of the last argument.
+@end deffn
+
+@node Time, Interrupts, Miscellaneous Procedures, The Language
+@section Time
+
+@defvr Constant internal-time-units-per-second
+
+Is the integer number of internal time units in a second.
+@end defvr
+
+@defun get-internal-run-time
+Returns the integer run time in internal time units from an unspecified
+starting time. The difference of two calls to
+@code{get-internal-run-time} divided by
+@code{internal-time-units-per-second} will give elapsed run time in
+seconds.
+@end defun
+
+@defun get-internal-real-time
+Returns the integer time in internal time units from an unspecified
+starting time. The difference of two calls to
+@code{get-internal-real-time} divided by
+@code{interal-time-units-per-second} will give elapsed real time in
+seconds.
+@end defun
+
+@defun current-time
+Returns the time since 00:00:00 GMT, January 1, 1970, measured in
+seconds. @xref{Time, current-time, , slib, SLIB}. @code{current-time} is
+used in @ref{Time, , , slib, SLIB}.
+@end defun
+
+@node Interrupts, Process Synchronization, Time, The Language
+@section Interrupts
+
+@defun ticks n
+Returns the number of ticks remaining till the next tick interrupt.
+Ticks are an arbitrary unit of evaluation. Ticks can vary greatly in
+the amount of time they represent.
+
+If @var{n} is 0, any ticks request is canceled. Otherwise a
+@code{ticks-interrupt} will be signaled @var{n} from the current time.
+@code{ticks} is supported if SCM is compiled with the @code{ticks} flag
+defined.
+@end defun
+
+@deffn {Callback procedure} ticks-interrupt @dots{}
+Establishes a response for tick interrupts. Another tick interrupt will
+not occur unless @code{ticks} is called again. Program execution will
+resume if the handler returns. This procedure should (abort) or some
+other action which does not return if it does not want processing to
+continue.
+@end deffn
+
+@defun alarm secs
+Returns the number of seconds remaining till the next alarm interrupt.
+If @var{secs} is 0, any alarm request is canceled. Otherwise an
+@code{alarm-interrupt} will be signaled @var{secs} from the current
+time. ALARM is not supported on all systems.
+@end defun
+
+@deffn {Callback procedure} user-interrupt @dots{}
+@deffnx {Callback procedure} alarm-interrupt @dots{}
+Establishes a response for @code{SIGINT} (control-C interrupt) and
+@code{SIGALRM} interrupts. Program execution will resume if the handler
+returns. This procedure should @code{(abort)} or some other action
+which does not return if it does not want processing to continue after
+it returns.
+
+Interrupt handlers are disabled during execution @code{system} and
+@code{ed} procedures.
+
+To unestablish a response for an interrupt set the handler symbol to
+@code{#f}. For instance, @code{(set! user-interrupt #f)}.
+@end deffn
+
+@deffn {Callback procedure} out-of-storage @dots{}
+@deffnx {Callback procedure} could-not-open @dots{}
+@deffnx {Callback procedure} end-of-program @dots{}
+@deffnx {Callback procedure} hang-up @dots{}
+@deffnx {Callback procedure} arithmetic-error @dots{}
+Establishes a response for storage allocation error, file opening
+error, end of program, SIGHUP (hang up interrupt) and arithmetic
+errors respectively. This procedure should (abort) or some other
+action which does not return if it does not want the default error
+message to also be displayed. If no procedure is defined for @var{hang-up}
+then @var{end-of-program} (if defined) will be called.
+
+To unestablish a response for an error set the handler symbol to
+@code{#f}. For instance, @code{(set! could-not-open #f)}.
+@end deffn
+
+@node Process Synchronization, Files and Ports, Interrupts, The Language
+@section Process Synchronization
+
+@defun make-arbiter name
+
+Returns an object of type arbiter and name @var{name}. Its state is
+initially unlocked.
+@end defun
+
+@defun try-arbiter arbiter
+
+Returns @code{#t} and locks @var{arbiter} if @var{arbiter} was unlocked.
+Otherwise, returns @code{#f}.
+@end defun
+
+@defun release-arbiter arbiter
+
+Returns @code{#t} and unlocks @var{arbiter} if @var{arbiter} was locked.
+Otherwise, returns @code{#f}.
+@end defun
+
+@node Files and Ports, Soft Ports, Process Synchronization, The Language
+@section Files and Ports
+
+@noindent
+These procedures generalize and extend the standard capabilities in
+@ref{Ports, , ,r4rs, Revised(4) Scheme}.
+
+@defun open-file string modes
+Returns a port capable of receiving or delivering characters as
+specified by the @var{modes} string. If a file cannot be opened
+@code{#f} is returned.
+@end defun
+
+@defvr Constant open_read
+@defvrx Constant open_write
+@defvrx Constant open_both
+Contain modes strings specifying that a file is to be opened for
+reading, writing, and both reading and writing respectively.
+@end defvr
+
+@defun _ionbf modestr
+Returns a version of modestr which when open-file is called with it as
+the second argument will return an unbuffered port. A non-file
+input-port must be unbuffered in order for char-ready? to work correctly
+on it. The initial value of (current-input-port) is unbuffered if the
+platform supports it.
+@end defun
+
+@defun close-port port
+Closes @var{port}. The same as close-input-port and close-output-port.
+@end defun
+
+@defun open-io-file filename
+@defunx close-io-port port
+These functions are analogous to the standard scheme file functions.
+The ports are open to @var{filename} in read/write mode. Both input and
+output functions can be used with io-ports. An end of file must be read
+or a file-set-position done on the port between a read operation and a
+write operation or vice-versa.
+@end defun
+
+@defun current-error-port
+Returns the current port to which diagnostic output is directed.
+@end defun
+
+@defun with-error-to-file string thunk
+@var{thunk} must be a procedure of no arguments, and string must be a
+string naming a file. The file is opened for output, an output port
+connected to it is made the default value returned by
+current-error-port, and the @var{thunk} is called with no arguments. When
+the thunk returns, the port is closed and the previous default is
+restored. With-error-to-file returns the value yielded by @var{thunk}.
+@end defun
+
+@defun with-input-from-port port thunk
+@defunx with-output-to-port port thunk
+@defunx with-error-to-port port thunk
+These routines differ from with-input-from-file, with-output-to-file,
+and with-error-to-file in that the first argument is a port, rather
+than a string naming a file.
+@end defun
+
+@deffn {procedure} char-ready?
+@deffnx {procedure} char-ready? port
+
+Returns @code{#t} if a character is ready on the input @var{port} and
+returns @code{#f} otherwise. If @code{char-ready?} returns @code{#t}
+then
+@findex char-ready
+the next @code{read-char} operation on the given @var{port} is
+guaranteed
+@findex read-char
+not to hang. If the @var{port} is at end of file then
+@code{char-ready?} returns @code{#t}.
+@findex char-ready?
+@var{Port} may be omitted, in which case it defaults to
+the value returned by @code{current-input-port}.
+@findex current-input-port
+
+@emph{Rationale:} @code{Char-ready?} exists to make it possible for a program to
+@findex char-ready?
+accept characters from interactive ports without getting stuck waiting
+for input. Any input editors associated with such ports must ensure
+that characters whose existence has been asserted by @code{char-ready?}
+@findex char-ready?
+cannot be rubbed out. If @code{char-ready?} were to return @code{#f} at
+end of file, a port at end of file would be indistinguishable from an
+interactive port that has no ready characters.
+@c end rationale
+@end deffn
+
+
+@node Soft Ports, Syntax Extensions, Files and Ports, The Language
+@section Soft Ports
+
+@noindent
+A @dfn{soft-port} is a port based on a vector of procedures capable of
+accepting or delivering characters. It allows emulation of I/O ports.
+
+@defun make-soft-port vector modes
+Returns a port capable of receiving or delivering characters as
+specified by the @var{modes} string (@pxref{Files and Ports,
+open-file}). @var{vector} must be a vector of length 6. Its components
+are as follows:
+
+@enumerate 0
+@item
+procedure accepting one character for output
+@item
+procedure accepting a string for output
+@item
+thunk for flushing output
+@item
+thunk for getting one character
+@item
+thunk for closing port (not by garbage collection)
+@end enumerate
+
+For an output-only port only elements 0, 1, 2, and 4 need be
+procedures. For an input-only port only elements 3 and 4 need be
+procedures. Thunks 2 and 4 can instead be @code{#f} if there is no useful
+operation for them to perform.
+
+If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input,
+eof-object?, ,r4rs, Revised(4) Scheme}) it indicates that the port has
+reached end-of-file. For example:
+
+@example
+(define stdout (current-output-port))
+(define p (make-soft-port
+ (vector
+ (lambda (c) (write c stdout))
+ (lambda (s) (display s stdout))
+ (lambda () (display "." stdout))
+ (lambda () (char-upcase (read-char)))
+ (lambda () (display "@@" stdout)))
+ "rw"))
+
+(write p p) @result{} #<input-output-soft#\space45d10#\>
+@end example
+@end defun
+
+@node Syntax Extensions, Low Level Syntactic Hooks, Soft Ports, The Language
+@section Syntax Extensions
+
+@deffn {Read syntax} #. expression
+Is read as the object resulting from the evaluation of @var{expression}.
+This substitution occurs even inside quoted structure.
+
+In order to allow compiled code to work with @code{#.} it is good
+practice to define those symbols used inside of @var{expression} with
+@code{#.(define @dots{})}. For example:
+
+@example
+#.(define foo 9) @result{} #<unspecified>
+'(#.foo #.(+ foo foo)) @result{} (9 18)
+@end example
+@end deffn
+
+@deffn {Read syntax} #+ feature form
+If feature is @code{provided?} (by @code{*features*}) then @var{form} is
+read as a scheme expression. If not, then @var{form} is treated as
+whitespace.
+
+Feature is a boolean expression composed of symbols and @code{and},
+@code{or}, and @code{not} of boolean expressions.
+
+For more information on @code{provided?} and @code{*features*},
+@xref{Require, , , slib, SLIB}.
+@end deffn
+
+@deffn {Read syntax} #- feature form
+is equivalent to @code{#+(not feature) expression}.
+@end deffn
+
+@deffn {Read syntax} #' form
+is equivalent to @var{form} (for compatibility with common-lisp).
+@end deffn
+
+@deffn {Read syntax} #| any thing |#
+Is a balanced comment. Everything up to the matching @code{|#} is
+ignored by the @code{read}. Nested @code{#|@dots{}|#} can occur inside
+@var{any thing}.
+@end deffn
+
+@deffn {Read syntax} #! any thing
+On the first line of a file will be ignored when loaded by SCM. This
+makes SCM files usable as POSIX shell scripts if the first line is:
+
+@example
+#!/usr/local/bin/scm
+@end example
+
+When such a file is invoked it executes /usr/local/bin/scm with the
+name of this file as the first argument. The following shell script
+will print factorial of its argument:
+@example
+#!/usr/local/bin/scm
+;;; -*-scheme-*- tells emacs this is a scheme file.
+(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
+(display (fact (string->number (caddr (program-arguments)))))
+(newline)
+(quit)
+@end example
+
+This technique has some drawbacks:
+@itemize @bullet
+@item
+Some Unixes limit the length of the @samp{#!} interpreter line to the
+size of an object file header, which can be as small as 32 bytes.
+@item
+A full, explicit pathname must be specified, perhaps requiring more than
+32 bytes and making scripts vulnerable to programs being moved.
+@end itemize
+
+The following approach solves both problems -- at the expense of
+slightly slower startup. @code{type;} should appear on every line to be
+executed by the shell. These lines do not have the length restriction
+mentioned above. Also, @code{/bin/sh} searches the directories listed
+in the `PATH' environment variable for @samp{scm}, eliminating the need
+to know absolute locations in order to invoke a program.
+@example
+#!/bin/sh
+type;exec scm $0 $*
+;;; -*-scheme-*- tells emacs this is a scheme file.
+(define (fact n) (if (< n 2) 1 (* n (fact (+ -1 n)))))
+(display (fact (string->number (caddr (program-arguments)))))
+(newline)
+(quit)
+@end example
+@end deffn
+
+@defspec defined? symbol
+Equivalent to @code{#t} if @var{symbol} is a syntactic keyword (such as
+@code{if}) or a symbol with a value in the top level environment
+(@pxref{Variables and regions, , ,r4rs, Revised(4) Scheme}). Otherwise
+equivalent to @code{#f}.
+@end defspec
+
+@defspec defvar identifier initial-value
+If @var{identifier} is unbound in the top level environment, then
+@var{identifier} is @code{define}d to the result of evaluating the form
+@var{initial-value} as if the @code{defvar} form were instead the form
+@code{(define identifier initial-value)} . If @var{identifier} already
+has a value, then @var{initial-value} is @emph{not} evaluated and
+@var{identifier}'s value is not changed.
+@end defspec
+
+@noindent
+SCM also supports the following constructs from Common Lisp:
+@code{defmacro}, @code{macroexpand}, @code{macroexpand-1}, and
+@code{gentemp}. @xref{Defmacro, , , slib, SLIB}.
+
+
+@node Low Level Syntactic Hooks, , Syntax Extensions, The Language
+@section Low Level Syntactic Hooks
+
+@deffn {Callback procedure} read:sharp c port
+If a @key{#} followed by a character (for a non-standard syntax) is
+encountered by @code{read}, @code{read} will call the value of the
+symbol @code{read:sharp} with arguments the character and the port being
+read from. The value returned by this function will be the value of
+@code{read} for this expression unless the function returns
+@code{#<unspecified>} in which case the expression will be treated as
+whitespace. @code{#<unspecified>} is the value returned by the
+expression @code{(if #f #f)}.
+
+@emph{Note:} When adding new @key{#} syntaxes, have your code save the
+previous value of @code{read:sharp} when defining it. Call this saved
+value if an invocation's syntax is not recognized. This will allow
+@code{#+}, @code{#-}, @code{#!}, and @ref{Uniform Array}s to still be
+supported (as they use @code{read:sharp}).
+@end deffn
+
+@defun procedure->syntax proc
+Returns a @dfn{macro} which, when a symbol defined to this value appears
+as the first symbol in an expression, returns the result of applying
+@var{proc} to the expression and the environment.
+@end defun
+
+@defun procedure->macro proc
+@defunx procedure->memoizing-macro proc
+Returns a @dfn{macro} which, when a symbol defined to this value appears
+as the first symbol in an expression, evaluates the result of applying
+@var{proc} to the expression and the environment. The value returned
+from @var{proc} which has been passed to
+@code{PROCEDURE->MEMOIZING-MACRO} replaces the form passed to
+@var{proc}. For example:
+
+@example
+(define trace
+ (procedure->macro
+ (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))
+
+(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).
+@end example
+
+An @dfn{environment} is a list of @dfn{environment frames}. There are 2
+types of environment frames:
+
+@table @code
+@item ((lambda (variable1 @dots{}) @dots{}) value1 @dots{})
+@itemx (let ((variable1 value1) (variable2 value2) @dots{}) @dots{})
+@itemx (letrec ((variable1 value1) @dots{}) @dots{})
+result in a single enviroment frame:
+@example
+((variable1 @dots{}) value1 @dots{})
+@end example
+
+@item (let ((variable1 value1)) @dots{})
+@itemx (let* ((variable1 value1) @dots{}) @dots{})
+result in an environment frame for each variable:
+@example
+(variable1 . value1) (variable2 . value2) @dots{}
+@end example
+@end table
+@end defun
+
+@defspec @@apply procedure argument-list
+Returns the result of applying procedure to argument-list. (apply
+procedure argument-list) will produce the same result.
+@end defspec
+
+@defspec @@call-with-current-continuation procedure)
+Returns the result of applying @var{procedure} to the current
+continuation. A @dfn{continuation} is a SCM object of type
+@code{contin} (@pxref{Continuations}). The procedure
+@code{(call-with-current-continuation @var{procedure})} is defined to
+have the same effect as @code{(@@call-with-current-continuation
+procedure)}.
+@end defspec
+
+
+@node Packages, The Implementation, The Language, Top
+@chapter Packages
+
+@menu
+* Executable path::
+* Compiling And Linking:: Hobbit and Dynamic Linking
+* Dynamic Linking::
+* Dump:: Create Fast-Booting Executables
+* Numeric:: Numeric Language Extensions
+* Arrays:: As in APL
+* I/O-Extensions:: 'i/o-extensions
+* Posix Extensions:: 'posix
+* Regular Expression Pattern Matching:: 'regex
+* Line Editing:: 'edit-line
+* Curses:: Screen Control
+* Sockets:: Cruise the Net
+@end menu
+
+@node Executable path, Compiling And Linking, Packages, Packages
+@section Executable path
+
+In order to dump a saved executable or to dynamically-link using DLD,
+SCM must know where its executable file is. Sometimes SCM
+(@pxref{Executable Pathname}) guesses incorrectly the location of the
+currently running executable. In that case, the correct path can be set
+by calling @code{execpath} with the pathname.
+
+@defun execpath
+Returns the path (string) which SCM uses to find the executable file
+whose invocation the currently running session is, or #f if the path is
+not set.
+@defunx execpath #f
+@defunx execpath newpath
+Sets the path to @code{#f} or @var{newpath}, respectively. The old path
+is returned.
+@end defun
+
+@node Compiling And Linking, Dynamic Linking, Executable path, Packages
+@section Compiling And Linking
+
+@defun compile-file name1 name2 @dots{}
+If the HOBBIT compiler is installed in the
+@code{(implementation-vicinity)}, compiles the files @var{name1}
+@var{name2} @dots{} to an object file name @var{name1}<object-suffix>,
+where <object-suffix> is the object file suffix for your computer (for
+instance, @file{.o}). @var{name1} must be in the current directory;
+@var{name2} @dots{} can be in other directories.
+@end defun
+
+@defun link-named-scm name module1 @dots{}
+Creates a new SCM executable with name @var{name}. @var{name} will
+include the object modules @var{module1} @dots{} which can be produced
+with @code{compile-file}.
+
+@example
+cd ~/scm/
+scm -e'(link-named-scm"cute""cube")'
+(delete-file "scmflags.h")
+(call-with-output-file
+ "scmflags.h"
+ (lambda (fp)
+ (for-each
+ (lambda (string) (write-line string fp))
+ '("#define IMPLINIT \"/home/jaffer/scm/Init.scm\""
+ "#define COMPILED_INITS init_cube();"
+ "#define BIGNUMS"
+ "#define FLOATS"
+ "#define ARRAYS"))))
+(system "gcc -Wall -O2 -c continue.c findexec.c time.c
+ repl.c scl.c eval.c sys.c subr.c unif.c rope.c scm.c")
+@dots{}
+scm.c: In function `scm_init_extensions':
+scm.c:95: warning: implicit declaration of function `init_cube'
+scm.c: In function `scm_cat_path':
+scm.c:589: warning: implicit declaration of function `realloc'
+scm.c:594: warning: implicit declaration of function `malloc'
+scm.c: In function `scm_try_path':
+scm.c:612: warning: implicit declaration of function `free'
+(system "cc -o cute continue.o findexec.o time.o repl.o scl.o
+ eval.o sys.o subr.o unif.o rope.o scm.o cube.o -lm -lc")
+
+Compilation finished at Sun Jul 21 00:59:17
+@end example
+@end defun
+
+@node Dynamic Linking, Dump, Compiling And Linking, Packages
+@section Dynamic Linking
+
+@noindent
+If SCM has been compiled with @file{dynl.c} then the additional
+properties of load and require (from [SLIB]) specified here are
+supported. The @code{require} forms are preferred. The variable
+@code{*catalog*} can be extended to define other @code{require}-able
+packages. See @file{Link.scm} for details.
+
+@defun load filename lib1 @dots{}
+In addition to the [R4RS] requirement of loading Scheme expressions if
+@var{filename} is a Scheme source file, @code{load} will also
+dynamically load/link object files (produced by @code{compile-file}, for
+instance). The object-suffix need not be given to load. For example,
+
+@example
+(load (in-vicinity (implementation-vicinity) "sc2"))
+or (load (in-vicinity (implementation-vicinity) "sc2.o"))
+or (require 'rev2-procedures)
+or (require 'rev3-procedures)
+@end example
+
+will load/link @file{sc2.o} if it exists.
+
+The @var{lib1} @dots{} pathnames are for additional libraries which may be
+needed for object files not produced by the Hobbit compiler. For
+instance, crs is linked on Linux by
+
+@example
+(load (in-vicinity (implementation-vicinity) "crs.o")
+ (usr:lib "ncurses") (usr:lib "c"))
+or (require 'curses)
+@end example
+
+Turtlegr graphics library is linked by:
+
+@example
+(load (in-vicinity (implementation-vicinity) "turtlegr")
+ (usr:lib "X11") (usr:lib "c") (usr:lib "m"))
+or (require 'turtle-graphics)
+@end example
+
+And the string regular expression (@pxref{Regular Expression Pattern
+Matching}) package is linked by:
+
+@example
+(load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c"))
+@end example
+or
+@example
+(require 'regex)
+@end example
+@end defun
+
+@defun require 'db
+@defunx require 'wb
+Either form will dynamically load the WB database system from the
+wb:vicinity (@file{../wb/}) specified in @file{Link.scm}. See
+@file{scm/ANNOUNCE} for ftp sites where WB is available.
+@end defun
+
+@noindent
+The following functions comprise the low-level Scheme interface to
+dynamic linking. See the file @file{Link.scm} in the SCM distribution
+for an example of their use.
+
+@defun dyn:link filename
+@var{filename} should be a string naming an @dfn{object} or
+@dfn{archive} file, the result of C-compiling. The @code{dyn:link}
+procedure links and loads @var{filename} into the current SCM session.
+If successfull, @code{dyn:link} returns a @dfn{link-token} suitable for
+passing as the second argument to @code{dyn:call}. If not successful,
+@code{#f} is returned.
+@end defun
+
+@defun dyn:call name link-token
+@var{link-token} should be the value returned by a call to
+@code{dyn:link}. @var{name} should be the name of C function of no
+arguments defined in the file named @var{filename} which was succesfully
+@code{dyn:link}ed in the current SCM session. The @code{dyn:call}
+procedure calls the C function corresponding to @var{name}. If
+successful, @code{dyn:call} returns @code{#t}; If not successful,
+@code{#f} is returned.
+
+@code{dyn:call} is used to call the @dfn{init_@dots{}} function after
+loading SCM object files. The init_@dots{} function then makes the
+identifiers defined in the file accessible as Scheme procedures.
+@end defun
+
+@defun dyn:main-call name link-token arg1 @dots{}
+@var{link-token} should be the value returned by a call to
+@code{dyn:link}. @var{name} should be the name of C function of 2
+arguments, @code{(int argc, char **argv)}, defined in the file named
+@var{filename} which was succesfully @code{dyn:link}ed in the current
+SCM session. The @code{dyn:main-call} procedure calls the C function
+corresponding to @var{name} with @code{argv} style arguments, such as
+are given to C @code{main} functions. If successful,
+@code{dyn:main-call} returns the integer returned from the call to
+@var{name}.
+
+@code{dyn:main-call} can be used to call a @code{main} procedure from
+SCM. For example, I link in and @code{dyn:main-call} a large C program,
+the low level routines of which callback (@pxref{Callbacks}) into SCM
+(which emulates PCI hardware).
+@end defun
+
+@defun dyn:unlink link-token
+@var{link-token} should be the value returned by a call to
+@code{dyn:link}. The @code{dyn:unlink} procedure removes the previously
+loaded file from the current SCM session. If successful,
+@code{dyn:unlink} returns @code{#t}; If not successful, @code{#f} is
+returned.
+@end defun
+
+@defun usr:lib lib
+Returns the pathname of the C library named lib. For example:
+@code{(usr:lib "m")} could return @code{"/usr/lib/libm.a"}, the path of
+the C math library.
+@end defun
+
+@node Dump, Numeric, Dynamic Linking, Packages
+@section Dump
+
+@dfn{Dump}, (also known as @dfn{unexec}), saves the continuation of an
+entire SCM session to an executable file, which can then be invoked as a
+program. Dumped executables start very quickly, since no Scheme code
+has to be loaded.
+
+@noindent
+There are constraints on which sessions are savable using @code{dump}
+
+@itemize @bullet
+@item
+Saved continuations are invalid in subsequent invocations; they cause
+segmentation faults and other unpleasant side effects.
+@item
+Although DLD (@pxref{Dynamic Linking}) can be used to load compiled
+modules both before and after dumping, @samp{SUN_DL} ELF systems can
+load compiled modules only after dumping. This can be worked around by
+compiling in those features you wish to @code{dump}.
+@item
+Ports (other than @code{current-input-port}, @code{current-output-port},
+@code{current-error-port}), X windows, etc. are invalid in subsequent
+invocations.
+
+This restriction could be removed; @xref{Improvements To Make}.
+@item
+@code{Dump} should only be called from a loading file when the call to
+dump is the last expression in that file.
+@item
+@code{Dump} can be called from the command line.
+@end itemize
+
+@defun dump newpath
+@defunx dump newpath #f
+@defunx dump newpath #t
+@defunx dump newpath thunk
+@itemize @bullet
+@item
+Calls @code{gc}.
+@item
+Creates an executable program named @var{newpath} which continues the
+state of the current SCM session when invoked. The optional argument
+@var{thunk}, if provided, should be a procedure of no arguments. This
+procedure will be called in the restored executable.
+
+If the optional argument is missing or a boolean, SCM's standard command
+line processing will be called in the restored executable.
+
+If the second argument to @code{dump} is @code{#t}, argument processing
+will continue from the command line passed to the dumping session. If
+the second argument is missing or @code{#f} then the command line
+arguments of the restoring invocation will be processed.
+@item
+Resumes the top level Read-Eval-Print loop. This is done instead of
+continuing normally to avoid creating a saved continuation in the dumped
+executable.
+@end itemize
+
+@code{dump} may set the values of @code{boot-tail}, @code{*argv*},
+@code{restart}, and @var{*interactive*}. @code{dump} returns an
+unspecified value.
+@end defun
+
+When a dumped executable is invoked, the variable @var{*interactive*}
+(@pxref{System Interface}) has the value it possessed when @code{dump}
+created it. Calling @code{dump} with a single argument sets
+@var{*interactive*} to @code{#f}, which is the state it has at the
+beginning of command line processing.
+
+The procedure @code{program-arguments} returns the command line
+arguments for the curent invocation. More specifically,
+@code{program-arguments} for the restored session are @emph{not} saved
+from the dumping session. Command line processing is done on
+the value of the identifier @code{*argv*}.
+
+The thunk @code{boot-tail} is called by SCM to process command line
+arguments. @code{dump} sets @code{boot-tail} to the @var{thunk} it is
+called with.
+
+The following example shows how to create @samp{rscm}, which is like
+regular scm, but which loads faster and has the @samp{random} package
+alreadly provided.
+
+@example
+bash$ scm -rrandom
+> (dump "rscm")
+#<unspecified>
+> (quit)
+bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)"
+00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
+37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
+70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
+08128 48111 74502 84102 70193 85211 05559 64462 29489
+bash$
+@end example
+
+This task can also be accomplished using the @samp{-o} command line
+option (@pxref{SCM Options}).
+
+@example
+bash$ scm -rrandom -o rscm
+> (quit)
+bash$ ./rscm -lpi.scm -e"(pi (random 200) 5)"
+00003 14159 26535 89793 23846 26433 83279 50288 41971 69399
+37510 58209 74944 59230 78164 06286 20899 86280 34825 34211
+70679 82148 08651 32823 06647 09384 46095 50582 23172 53594
+08128 48111 74502 84102 70193 85211 05559 64462 29489
+bash$
+@end example
+
+@node Numeric, Arrays, Dump, Packages
+@section Numeric
+
+@defvr Constant most-positive-fixnum
+The immediate integer closest to positive infinity.
+@xref{Configuration, , , slib, SLIB}.
+@end defvr
+
+@defvr Constant most-negative-fixnum
+The immediate integer closest to negative infinity.
+@end defvr
+
+@noindent
+These procedures augment the standard capabilities in @ref{Numerical
+operations, , ,r4rs, Revised(4) Scheme}.
+
+@defun sinh z
+@defunx cosh z
+@defunx tanh z
+Return the hyperbolic sine, cosine, and tangent of @var{z}
+@end defun
+
+@defun asinh z
+@defunx acosh z
+@defunx atanh z
+Return the inverse hyperbolic sine, cosine, and tangent of @var{z}
+@end defun
+
+@defun $sqrt x
+@defunx $abs x
+@defunx $exp x
+@defunx $log x
+@defunx $sin x
+@defunx $cos x
+@defunx $tan x
+@defunx $asin x
+@defunx $acos x
+@defunx $atan x
+
+@defunx $sinh x
+@defunx $cosh x
+@defunx $tanh x
+@defunx $asinh x
+@defunx $acosh x
+@defunx $atanh x
+Real-only versions of these popular functions. The argument @var{x}
+must be a real number. It is an error if the value which should be
+returned by a call to these procedures is @emph{not} real.
+@end defun
+
+@defun $atan2 y x
+Computes @code{(angle (make-rectangular x y))} for real numbers @var{y}
+and @var{x}.
+@end defun
+
+@defun $expt x1 x2
+Returns real number @var{x1} raised to the real power @var{x2}. It is
+an error if the value which should be returned by a call to @code{$expt}
+is not real.
+@end defun
+
+@node Arrays, I/O-Extensions, Numeric, Packages
+@section Arrays
+
+@menu
+* Conventional Arrays::
+* Array Mapping::
+* Uniform Array::
+* Bit Vectors::
+@end menu
+
+@node Conventional Arrays, Array Mapping, Arrays, Arrays
+@subsection Conventional Arrays
+
+@dfn{Arrays} read and write as a @code{#} followed by the @dfn{rank}
+(number of dimensions) followed by what appear as lists (of lists) of
+elements. The lists must be nested to the depth of the rank. For each
+depth, all lists must be the same length.
+@example
+(make-array 'ho 3 3) @result{}
+#2((ho ho ho) (ho ho ho) (ho ho ho))
+@end example
+
+Unshared conventional (not uniform) 0-based arrays of rank 1 (dimension)
+are equivalent to (and can't be distinguished from) vectors.
+@example
+(make-array 'ho 3) @result{} (ho ho ho)
+@end example
+
+When constructing an array, @var{bound} is either an inclusive range of
+indices expressed as a two element list, or an upper bound expressed
+as a single integer. So
+@example
+(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
+@end example
+
+@defun array? obj
+Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.
+@end defun
+
+@defun make-array initial-value bound1 bound2 @dots{}
+Creates and returns an array that has as many dimensions as there are
+@var{bound}s and fills it with @var{initial-value}.
+@end defun
+
+@defun array-ref array index1 index2 @dots{}
+Returns the @var{index1}, @var{index2}, @dots{}'th element of
+@var{array}.
+@end defun
+
+@defun array-in-bounds? array index1 index2 @dots{}
+Returns @code{#t} if its arguments would be acceptable to @var{array-ref}.
+@end defun
+
+@defun array-set! array new-value index1 index2 @dots{}
+Sets the @var{index1}, @var{index2}, @dots{}'th element of @var{array}
+to @var{new-value}. The value returned by @code{array-set!} is
+unspecified.
+@end defun
+
+@defun make-shared-array array mapper bound1 bound2 @dots{}
+@code{make-shared-array} can be used to create shared subarrays of other
+arrays. The @var{mapper} is a function that translates coordinates in
+the new array into coordinates in the old array. A @var{mapper} must be
+linear, and its range must stay within the bounds of the old array, but
+it can be otherwise arbitrary. A simple example:
+@example
+(define fred (make-array #f 8 8))
+(define freds-diagonal
+ (make-shared-array fred (lambda (i) (list i i)) 8))
+(array-set! freds-diagonal 'foo 3)
+(array-ref fred 3 3) @result{} foo
+(define freds-center
+ (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))
+(array-ref freds-center 0 0) @result{} foo
+@end example
+@end defun
+
+@defun transpose-array array dim0 dim1 @dots{}
+Returns an array sharing contents with @var{array}, but with dimensions
+arranged in a different order. There must be one @var{dim} argument for
+each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should
+be integers between 0 and the rank of the array to be returned. Each
+integer in that range must appear at least once in the argument list.
+
+The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions
+in the array to be returned, their positions in the argument list to
+dimensions of @var{array}. Several @var{dim}s may have the same value,
+in which case the returned array will have smaller rank than
+@var{array}.
+
+examples:
+@example
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end example
+@end defun
+
+@defun enclose-array array dim0 dim1 @dots{}
+@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than
+the rank of @var{array}. @var{enclose-array} returns an array
+resembling an array of shared arrays. The dimensions of each shared
+array are the same as the @var{dim}th dimensions of the original array,
+the dimensions of the outer array are the same as those of the original
+array that did not match a @var{dim}.
+
+An enclosed array is not a general Scheme array. Its elements may not
+be set using @code{array-set!}. Two references to the same element of
+an enclosed array will be @code{equal?} but will not in general be
+@code{eq?}. The value returned by @var{array-prototype} when given an
+enclosed array is unspecified.
+
+examples:
+@example
+(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}
+ #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>
+
+(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}
+ #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>
+@end example
+@end defun
+
+@defun array-shape array
+Returns a list of inclusive bounds of integers.
+@example
+(array-shape (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 4))
+@end example
+@end defun
+
+@defun array-dimensions array
+@code{Array-dimensions} is similar to @code{array-shape} but replaces
+elements with a @code{0} minimum with one greater than the maximum. So:
+@example
+(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)
+@end example
+@end defun
+
+@defun array-rank obj
+Returns the number of dimensions of @var{obj}. If @var{obj} is not an
+array, @code{0} is returned.
+@end defun
+
+@defun array->list array
+Returns a list consisting of all the elements, in order, of @var{array}.
+@end defun
+
+@defun array-copy! source destination
+Copies every element from vector or array @var{source} to the
+corresponding element of @var{destination}. @var{destination} must have
+the same rank as @var{source}, and be at least as large in each
+dimension. The order of copying is unspecified.
+@end defun
+
+@defun serial-array-copy! source destination
+Same as @code{array-copy!} but guaranteed to copy in row-major order.
+@end defun
+
+@defun array-fill! array fill
+Stores @var{fill} in every element of @var{array}. The value returned
+is unspecified.
+@end defun
+
+@defun array-equal? array0 array1 @dots{}
+Returns @code{#t} iff all arguments are arrays with the same shape, the
+same type, and have corresponding elements which are either
+@code{equal?} or @code{array-equal?}. This function differs from
+@code{equal?} in that a one dimensional shared array may be
+@var{array-equal?} but not @var{equal?} to a vector or uniform vector.
+@end defun
+
+@defun array-contents array
+@defunx array-contents array strict
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @var{make-array} and
+@var{make-uniform-array} may be unrolled, some arrays made by
+@var{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end defun
+
+@node Array Mapping, Uniform Array, Conventional Arrays, Arrays
+@subsection Array Mapping
+
+@defun array-map! array0 proc array1 @dots{}
+
+If @var{array1}, @dots{} are arrays, they must have the same number of
+dimensions as @var{array0} and have a range for each index which
+includes the range for the corresponding index in @var{array0}.
+If they are scalars, that is, not arrays, vectors, or strings, then
+they will be converted internally to arrays of the appropriate shape.
+@var{proc} is applied to each tuple of elements of @var{array1} @dots{}
+and the result is stored as the corresponding element in @var{array0}.
+The value returned is unspecified. The order of application is
+unspecified.
+
+@end defun
+
+@defun serial-array-map! array0 proc array1 @dots{}
+Same as @var{array-map!}, but guaranteed to apply @var{proc} in
+row-major order.
+@end defun
+
+@defun array-for-each proc array0 @dots{}
+@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
+in row-major order. The value returned is unspecified.
+@end defun
+
+@defun array-index-map! array proc
+applies @var{proc} to the indices of each element of @var{array} in
+turn, storing the result in the corresponding element. The value
+returned and the order of application are unspecified.
+
+One can implement @var{array-indexes} as
+@example
+(define (array-indexes array)
+ (let ((ra (apply make-array #f (array-shape array))))
+ (array-index-map! ra (lambda x x))
+ ra))
+@end example
+Another example:
+@example
+(define (apl:index-generator n)
+ (let ((v (make-uniform-vector n 1)))
+ (array-index-map! v (lambda (i) i))
+ v))
+@end example
+@end defun
+
+@defun scalar->array scalar array prototype
+Returns a uniform array of the same shape as @var{array}, having only
+one shared element, which is @code{eqv?} to @var{scalar}.
+If the optional argument @var{prototype} is supplied it will be used
+as the prototype for the returned array. Otherwise the returned array
+will be of the same type as @code{array} if that is possible, and
+a conventional array if it is not. This function is used internally
+by @code{array-map!} and friends to handle scalar arguments.
+@end defun
+
+@node Uniform Array, Bit Vectors, Array Mapping, Arrays
+@subsection Uniform Array
+
+@noindent
+@dfn{Uniform Arrays} and vectors are arrays whose elements are all of
+the same type. Uniform vectors occupy less storage than conventional
+vectors. Uniform Array procedures also work on vectors,
+uniform-vectors, bit-vectors, and strings.
+
+@noindent
+@var{prototype} arguments in the following procedures are interpreted
+according to the table:
+
+@example
+prototype type display prefix
+
+#t boolean (bit-vector) #b
+#\a char (string) #a
+integer >0 unsigned integer #u
+integer <0 signed integer #e
+1.0 float (single precision) #s
+1/3 double (double precision float) #i
++i complex (double precision) #c
+() conventional vector #
+@end example
+
+@noindent
+Unshared uniform character 0-based arrays of rank 1 (dimension)
+are equivalent to (and can't be distinguished from) strings.
+@example
+(make-uniform-array #\a 3) @result{} "$q2"
+@end example
+
+@noindent
+Unshared uniform boolean 0-based arrays of rank 1 (dimension) are
+equivalent to (and can't be distinguished from) @ref{Bit Vectors,
+bit-vectors}.
+@example
+(make-uniform-array #t 3) @result{} #*000
+@equiv{}
+#b(#f #f #f) @result{} #*000
+@equiv{}
+#1b(#f #f #f) @result{} #*000
+@end example
+
+@noindent
+Other uniform vectors are written in a form similar to that of vectors,
+except that a single character from the above table is put between
+@code{#} and @code{(}. For example, @code{'#e(3 5 9)} returns a uniform
+vector of signed integers.
+
+@defun uniform-vector-ref uve index
+Returns the element at the @var{index} element in @var{uve}.
+@end defun
+
+@defun uniform-vector-set! uve index new-value
+Sets the element at the @var{index} element in @var{uve} to
+@var{new-value}. The value returned by @code{uniform-vector-set!} is
+unspecified.
+@end defun
+
+@defun array? obj prototype
+Returns @code{#t} if the @var{obj} is an array of type corresponding to
+@var{prototype}, and @code{#f} if not.
+@end defun
+
+@defun make-uniform-array prototype bound1 bound2 @dots{}
+Creates and returns a uniform array of type corresponding to
+@var{prototype} that has as many dimensions as there are @var{bound}s
+and fills it with @var{prototype}.
+@end defun
+
+@defun array-prototype array
+Returns an object that would produce an array of the same type as
+@var{array}, if used as the @var{prototype} for
+@code{make-uniform-array}.
+@end defun
+
+@defun list->uniform-array rank prot lst
+@defunx list->uniform-vector prot lst
+Returns a uniform array of the type indicated by prototype @var{prot}
+with elements the same as those of @var{lst}. Elements must be of the
+appropriate type, no coercions are done.
+@end defun
+
+@defun uniform-vector-fill! uve fill
+Stores @var{fill} in every element of @var{uve}. The value returned is
+unspecified.
+@end defun
+
+@defun uniform-vector-length uve
+Returns the number of elements in @var{uve}.
+@end defun
+
+@defun dimensions->uniform-array dims prototype fill
+@defunx dimensions->uniform-array dims prototype
+@defunx make-uniform-vector length prototype fill
+@defunx make-uniform-vector length prototype
+Creates and returns a uniform array or vector of type corresponding to
+@var{prototype} with dimensions @var{dims} or length @var{length}. If
+the @var{fill} argument is supplied, the returned array is filled with
+this value.
+@end defun
+
+@defun uniform-array-read! ura
+@defunx uniform-array-read! ura port
+@defunx uniform-vector-read! uve
+@defunx uniform-vector-read! uve port
+Attempts to read all elements of @var{ura}, in lexicographic order, as
+binary objects from @var{port}. If an end of file is encountered during
+uniform-array-read! the objects up to that point only are put into @var{ura}
+(starting at the beginning) and the remainder of the array is
+unchanged.
+
+@code{uniform-array-read!} returns the number of objects read.
+@var{port} may be omitted, in which case it defaults to the value
+returned by @code{(current-input-port)}.
+@end defun
+
+@defun uniform-array-write ura
+@defunx uniform-array-write ura port
+@defunx uniform-vector-write uve
+@defunx uniform-vector-write uve port
+Writes all elements of @var{ura} as binary objects to @var{port}. The
+number of of objects actually written is returned. @var{port} may be
+omitted, in which case it defaults to the value returned by
+@code{(current-output-port)}.
+@end defun
+
+@node Bit Vectors, , Uniform Array, Arrays
+@subsection Bit Vectors
+
+@noindent
+Bit vectors can be written and read as a sequence of @code{0}s and
+@code{1}s prefixed by @code{#*}.
+
+@example
+#b(#f #f #f #t #f #t #f) @result{} #*0001010
+@end example
+
+@noindent
+Some of these operations will eventually be generalized to other
+uniform-arrays.
+
+@defun bit-count bool bv
+Returns the number occurrences of @var{bool} in @var{bv}.
+@end defun
+
+@defun bit-position bool bv k
+Returns the minimum index of an occurrence of @var{bool} in @var{bv}
+which is at least @var{k}. If no @var{bool} occurs within the specified
+range @code{#f} is returned.
+@end defun
+
+@defun bit-invert! bv
+Modifies @var{bv} by replacing each element with its negation.
+@end defun
+
+@defun bit-set*! bv uve bool
+If uve is a bit-vector @var{bv} and uve must be of the same length. If
+@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the
+inversion of uve is AND'ed into @var{bv}.
+
+If uve is a unsigned integer vector all the elements of uve must be
+between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv}
+corresponding to the indexes in uve are set to @var{bool}.
+
+The return value is unspecified.
+@end defun
+
+@defun bit-count* bv uve bool
+Returns
+@example
+(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).
+@end example
+@var{bv} is not modified.
+@end defun
+
+
+@node I/O-Extensions, Posix Extensions, Arrays, Packages
+@section I/O-Extensions
+
+@noindent
+If @code{'i/o-extensions} is provided (by linking in @file{ioext.o}),
+@ref{Line I/O, , , slib, SLIB}, and the following functions are defined:
+
+@defun isatty? port
+Returns @code{#t} if @var{port} is input or output to a serial non-file device.
+@end defun
+
+@defun stat <port-or-string>
+Returns a vector of integers describing the argument. The argument
+can be either a string or an open input port. If the argument is an
+open port then the returned vector describes the file to which the
+port is opened; If the argument is a string then the returned vector
+describes the file named by that string. If there exists no file with
+the name string, or if the file cannot be accessed @code{#f} is returned.
+The elements of the returned vector are as follows:
+
+
+@table @r
+@item 0 st_dev
+ID of device containing a directory entry for this file
+@item 1 st_ino
+Inode number
+@item 2 st_mode
+File type, attributes, and access control summary
+@item 3 st_nlink
+Number of links
+@item 4 st_uid
+User ID of file owner
+@item 5 st_gid
+Group ID of file group
+@item 6 st_rdev
+Device ID; this entry defined only for char or blk spec files
+@item 7 st_size
+File size (bytes)
+@item 8 st_atime
+Time of last access
+@item 9 st_mtime
+Last modification time
+@item 10 st_ctime
+Last file status change time
+@end table
+@end defun
+
+@defun getpid
+Returns the process ID of the current process.
+@end defun
+
+@defun file-position port
+Returns the current position of the character in @var{port} which will
+next be read or written. If @var{port} is not open to a file the result
+is unspecified.
+@end defun
+
+@defun file-set-position port integer
+Sets the current position in @var{port} which will next be read or
+written. If @var{port} is not open to a file the action of
+@code{file-set-position} is unspecified. The result of
+@code{file-set-position} is unspecified.
+@end defun
+
+@defun reopen-file filename modes port
+Closes port @var{port} and reopens it with @var{filename} and
+@var{modes}. @code{reopen-file} returns @code{#t} if successful,
+@code{#f} if not.
+@end defun
+
+@defun duplicate-port port modes
+Creates and returns a @dfn{duplicate} port from @var{port}. Duplicate
+@emph{unbuffered} ports share one file position. @var{modes} are as for
+@ref{Files and Ports, open-file}.
+@end defun
+
+@defun redirect-port! from-port to-port
+Closes @var{to-port} and makes @var{to-port} be a duplicate of
+@var{from-port}. @code{redirect-port!} returns @var{to-port} if
+successful, @code{#f} if not. If unsuccessful, @var{to-port} is not
+closed.
+@end defun
+
+@defun opendir dirname
+Returns a @dfn{directory} object corresponding to the file system
+directory named @var{dirname}. If unsuccessful, returns @code{#f}.
+@end defun
+
+@defun readdir dir
+Returns the string name of the next entry from the directory @var{dir}.
+If there are no more entries in the directory, @code{readdir} returns a
+@code{#f}.
+@end defun
+
+@defun rewinddir dir
+Reinitializes @var{dir} so that the next call to @code{readdir} with
+@var{dir} will return the first entry in the directory again.
+@end defun
+
+@defun closedir dir
+Closes @var{dir} and returns @code{#t}. If @var{dir} is already
+closed,, @code{closedir} returns a @code{#f}.
+@end defun
+
+@defun mkdir path mode
+The @code{mkdir} function creates a new, empty directory whose name is
+@var{path}. The integer argument @var{mode} specifies the file
+permissions for the new directory. @xref{The Mode Bits for Access
+Permission, , , libc, Gnu C Library}, for more information about this.
+
+@code{mkdir} returns if successful, @code{#f} if not.
+@end defun
+
+@defun rmdir path
+The @code{rmdir} function deletes the directory @var{path}. The
+directory must be empty before it can be removed. @code{rmdir} returns
+if successful, @code{#f} if not.
+@end defun
+
+@defun chdir filename
+Changes the current directory to @var{filename}. If @var{filename} does not
+exist or is not a directory, @code{#f} is returned. Otherwise, @code{#t} is
+returned.
+@end defun
+
+@defun getcwd
+The function @code{getcwd} returns a string containing the absolute file
+name representing the current working directory. If this string cannot
+be obtained, @code{#f} is returned.
+@end defun
+
+@defun rename-file oldfilename newfilename
+Renames the file specified by @var{oldfilename} to @var{newfilename}.
+If the renaming is successful, @code{#t} is returned. Otherwise,
+@code{#f} is returned.
+@end defun
+
+@defun chmod file mode
+The function @code{chmod} sets the access permission bits for the file
+named by @var{file} to @var{mode}. The @var{file} argument may be a
+string containing the filename or a port open to the file.
+
+@code{chmod} returns if successful, @code{#f} if not.
+@end defun
+
+@defun utime pathname acctime modtime
+Sets the file times associated with the file named @var{pathname} to
+have access time @var{acctime} and modification time @var{modtime}.
+@code{utime} returns if successful, @code{#f} if not.
+@end defun
+
+@defun umask mode
+The function @code{umask} sets the file creation mask of the current
+process to @var{mask}, and returns the previous value of the file
+creation mask.
+@end defun
+
+@defun fileno port
+Returns the integer file descriptor associated with the port @var{port}.
+If an error is detected, @code{#f} is returned.
+@end defun
+
+@defun access pathname how
+Returns @code{#t} if the file named by @var{pathname} can be accessed in
+the way specified by the @var{how} argument. The @var{how} argument can
+be the @code{logior} of the flags:
+
+@enumerate 0
+@item
+File-exists?
+@item
+File-is-executable?
+@item
+File-is-writable?
+@end enumerate
+@enumerate 4
+@item
+File-is-readable?
+@end enumerate
+
+Or the @var{how} argument can be a string of 0 to 3 of the following
+characters in any order. The test performed is the @code{and} of the
+associated tests and @code{file-exists?}.
+
+@table @key
+@item x
+File-is-executable?
+@item w
+File-is-writable?
+@item r
+File-is-readable?
+@end table
+@end defun
+
+@defun execl command arg0 @dots{}
+@defunx execlp command arg0 @dots{}
+Transfers control to program @var{command} called with arguments
+@var{arg0} @dots{}. For @code{execl}, @var{command} must be an exact
+pathname of an executable file. @code{execlp} searches for
+@var{command} in the list of directories specified by the environment
+variable @var{PATH}. The convention is that @var{arg0} is the same name
+as @var{command}.
+
+If successful, this procedure does not return. Otherwise an error
+message is printed and the integer @code{errno} is returned.
+
+@defunx execv command arglist
+@defunx execvp command arglist
+Like @code{execl} and @code{execlp} except that the set of arguments to
+@var{command} is @var{arglist}.
+@end defun
+
+@defun putenv string
+adds or removes definitions from the @dfn{environment}. If the
+@var{string} is of the form @samp{NAME=VALUE}, the definition is added
+to the environment. Otherwise, the @var{string} is interpreted as the
+name of an environment variable, and any definition for this variable in
+the environment is removed.
+
+Names of environment variables are case-sensitive and must not contain
+the character @code{=}. System-defined environment variables are
+invariably uppercase.
+
+@code{Putenv} is used to set up the environment before calls to
+@code{execl}, @code{execlp}, @code{execv}, @code{execvp}, @code{system},
+or @code{open-pipe} (@pxref{I/O-Extensions, open-pipe}).
+
+To access environment variables, use @code{getenv} (@pxref{System
+Interface, getenv, , slib, SLIB}).
+@end defun
+
+@node Posix Extensions, Regular Expression Pattern Matching, I/O-Extensions, Packages
+@section Posix Extensions
+
+@noindent
+If @code{'posix} is provided (by linking in @file{posix.o}), the
+following functions are defined:
+
+@defun open-pipe string modes
+If the string @var{modes} contains an @key{r}, returns an input port
+capable of delivering characters from the standard output of the system
+command @var{string}. Otherwise, returns an output port capable of
+receiving characters which become the standard input of the system
+command @var{string}. If a pipe cannot be created @code{#f} is
+returned.
+@end defun
+
+@defun open-input-pipe string
+Returns an input port capable of delivering characters from the
+standard output of the system command @var{string}. If a pipe cannot be
+created @code{#f} is returned.
+@end defun
+
+@defun open-output-pipe string
+Returns an output port capable of receiving characters which become
+the standard input of the system command @var{string}. If a pipe cannot
+be created @code{#f} is returned.
+@end defun
+
+@defun close-port pipe
+Closes the @var{pipe}, rendering it incapable of delivering or accepting
+characters. This routine has no effect if the pipe has already been
+closed. The value returned is unspecified.
+@end defun
+
+@defun pipe
+Returns @code{(cons @var{rd} @var{wd})} where @var{rd} and @var{wd} are
+the read and write (port) ends of a @dfn{pipe} respectively.
+@end defun
+
+@defun fork
+Creates a copy of the process calling @code{fork}. Both processes
+return from @code{fork}, but the calling (@dfn{parent}) process's
+@code{fork} returns the @dfn{child} process's ID whereas the child
+process's @code{fork} returns 0.
+@end defun
+
+@noindent
+For a discussion of @dfn{ID}s @xref{Process Persona, , , GNU C Library,
+libc}.
+
+@defun getppid
+Returns the process ID of the parent of the current process.
+For a process's own ID @xref{I/O-Extensions, getpid}.
+@end defun
+
+@defun getuid
+Returns the real user ID of this process.
+@end defun
+
+@defun getgid
+Returns the real group ID of this process.
+@end defun
+
+@defun getegid
+Returns the effective group ID of this process.
+@end defun
+
+@defun geteuid
+Returns the effective user ID of this process.
+@end defun
+
+@defun setuid id
+Sets the real user ID of this process to @var{id}.
+Returns @code{#t} if successful, @code{#f} if not.
+@end defun
+
+@defun setgid id
+Sets the real group ID of this process to @var{id}.
+Returns @code{#t} if successful, @code{#f} if not.
+@end defun
+
+@defun setegid id
+Sets the effective group ID of this process to @var{id}.
+Returns @code{#t} if successful, @code{#f} if not.
+@end defun
+
+@defun seteuid id
+Sets the effective user ID of this process to @var{id}.
+Returns @code{#t} if successful, @code{#f} if not.
+@end defun
+
+@defun kill pid sig
+The @code{kill} function sends the signal @var{signum} to the process or
+process group specified by @var{pid}. Besides the signals listed in
+@ref{Standard Signals, , ,libc , GNU C Library}, @var{signum} can also
+have a value of zero to check the validity of the @var{pid}.
+
+The @var{pid} specifies the process or process group to receive the
+signal:
+
+@table @asis
+@item > 0
+The process whose identifier is @var{pid}.
+
+@item 0
+All processes in the same process group as the sender. The
+sender itself does not receive the signal.
+
+@item -1
+If the process is privileged, send the signal to all
+processes except for some special system processes.
+Otherwise, send the signal to all processes with the same
+effective user ID.
+
+@item < -1
+The process group whose identifier is @code{(abs @var{pid})}.
+@end table
+
+A process can send a signal to itself with @code{(kill (getpid)
+@var{signum})}. If @code{kill} is used by a process to send a signal to
+itself, and the signal is not blocked, then @code{kill} delivers at
+least one signal (which might be some other pending unblocked signal
+instead of the signal @var{signum}) to that process before it returns.
+
+The return value from @code{kill} is zero if the signal can be sent
+successfully. Otherwise, no signal is sent, and a value of @code{-1} is
+returned. If @var{pid} specifies sending a signal to several processes,
+@code{kill} succeeds if it can send the signal to at least one of them.
+There's no way you can tell which of the processes got the signal or
+whether all of them did.
+@end defun
+
+@defun waitpid pid options
+
+The @code{waitpid} function suspends execution of the current process
+until a child as specified by the @var{pid} argument has exited, or until a
+signal is deliverd whose action is to terminate the current process or
+to call a signal handling function. If a child as requested by @var{pid} has
+already exited by the time of the call (a so-called @dfn{zombie}
+process), the function returns immediately. Any system resources used
+by the child are freed.
+
+The value of @var{pid} can be one of:
+
+@table @asis
+@item < -1
+which means to wait for any child process whose process group ID is
+equal to the absolute value of
+
+@item -1
+which means to wait for any child process whose process group ID is
+equal to the @code{(abs @var{pid})}.
+
+@item -1
+which means to wait for any child process; this is the same behaviour
+which wait exhibits.
+
+@item 0
+which means to wait for any child process whose process group ID is
+equal to that of the calling process.
+
+@item > 0
+which means to wait for the child whose process ID is equal to the value
+of @var{pid}.
+@end table
+
+The value of @var{options} is one of the following:
+
+@enumerate 0
+@item
+Nothing special.
+
+@item
+(@code{WNOHANG}) which means to return immediately if no child is there
+to be waited for.
+
+@item
+(@code{WUNTRACED}) which means to also return for children which are
+stopped, and whose status has not been reported.
+
+@item
+Which means both of the above.
+@end enumerate
+
+The return value is normally the process ID of the child process whose
+status is reported. If the @code{WNOHANG} option was specified and no
+child process is waiting to be noticed, the value is zero. A value of
+@code{#f} is returned in case of error and @code{errno} is set. For
+information about the @code{errno} codes @xref{Process Completion, , ,
+GNU C Library, libc}.
+@end defun
+
+@defun uname
+You can use the @code{uname} procedure to find out some information
+about the type of computer your program is running on.
+
+Returns a vector of strings. These strings are:
+
+@enumerate 0
+@item
+The name of the operating system in use.
+@item
+The network name of this particular computer.
+@item
+The current release level of the operating system implementation.
+@item
+The current version level within the release of the operating system.
+@item
+Description of the type of hardware that is in use.
+
+Some examples are @samp{"i386-ANYTHING"}, @samp{"m68k-hp"},
+@samp{"sparc-sun"}, @samp{"m68k-sun"}, @samp{"m68k-sony"} and @samp{"mips-dec"}.
+@end enumerate
+@end defun
+
+@defun getpw name
+@defunx getpw uid
+@defunx getpw
+Returns a vector of information for the entry for @code{NAME},
+@code{UID}, or the next entry if no argument is given. The
+information is:
+
+@enumerate 0
+@item
+The user's login name.
+@item
+The encrypted password string.
+@item
+The user ID number.
+@item
+The user's default group ID number.
+@item
+A string typically containing the user's real name, and
+possibly other information such as a phone number.
+@item
+The user's home directory, initial working directory, or @code{#f}, in
+which case the interpretation is system-dependent.
+@item
+The user's default shell, the initial program run when the user logs in,
+or @code{#f}, indicating that the system default should be used.
+@end enumerate
+@end defun
+
+@defun setpwent #t
+Rewinds the pw entry table back to the begining.
+
+@defunx setpwent #f
+@defunx setpwent
+Closes the pw table.
+@end defun
+
+
+@defun getgr name
+@defunx getgr uid
+@defunx getgr
+Returns a vector of information for the entry for @code{NAME},
+@code{UID}, or the next entry if no argument is given. The
+information is:
+
+@enumerate 0
+@item
+The name of the group.
+@item
+The encrypted password string.
+@item
+The group ID number.
+@item
+A list of (string) names of users in the group.
+@end enumerate
+@end defun
+
+@defun setgrent #t
+Rewinds the group entry table back to the begining.
+
+@defunx setgrent #f
+@defunx setgrent
+Closes the group table.
+@end defun
+
+@defun getgroups
+Returns a vector of all the supplementary group IDs of the process.
+@end defun
+
+
+@defun link oldname newname
+The @code{link} function makes a new link to the existing file named by
+@var{oldname}, under the new name @var{newname}.
+
+@code{link} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun chown filename owner group
+The @code{chown} function changes the owner of the file @var{filename}
+to @var{owner}, and its group owner to @var{group}.
+
+@code{chown} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun ttyname port
+If port @var{port} is associated with a terminal device, returns a
+string containing the file name of termainal device; otherwise
+@code{#f}.
+@end defun
+
+@section Unix Extensions
+
+@noindent
+If @code{'unix} is provided (by linking in @file{unix.o}), the following
+functions are defined:
+
+@noindent
+These @dfn{priveledged} and symbolic link functions are not in Posix:
+
+@defun symlink oldname newname
+The @code{symlink} function makes a symbolic link to @var{oldname} named
+@var{newname}.
+
+@code{symlink} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun readlink filename
+Returns the value of the symbolic link @var{filename} or @code{#f} for
+failure.
+@end defun
+
+@defun lstat filename
+The @code{lstat} function is like @code{stat}, except that it does not
+follow symbolic links. If @var{filename} is the name of a symbolic
+link, @code{lstat} returns information about the link itself; otherwise,
+@code{lstat} works like @code{stat}. @xref{I/O-Extensions}.
+@end defun
+
+@defun nice increment
+Increment the priority of the current process by @var{increment}.
+@code{chown} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun acct filename
+When called with the name of an exisitng file as argument, accounting is
+turned on, records for each terminating pro-cess are appended to
+@var{filename} as it terminates. An argument of @code{#f} causes
+accounting to be turned off.
+
+@code{acct} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun mknod filename mode dev
+The @code{mknod} function makes a special file with name @var{filename}
+and modes @var{mode} for device number @var{dev}.
+
+@code{mknod} returns a value of @code{#t} if it is successful and
+@code{#f} on failure.
+@end defun
+
+@defun sync
+@code{sync} first commits inodes to buffers, and then buffers to disk.
+sync() only schedules the writes, so it may return before the actual
+writing is done. The value returned is unspecified.
+@end defun
+
+@node Regular Expression Pattern Matching, Line Editing, Posix Extensions, Packages
+@section Regular Expression Pattern Matching
+
+These functions are defined in @file{rgx.c} using a POSIX or GNU
+@dfn{regex} library. If your computer does not support regex, a package
+is available via ftp from
+@file{prep.ai.mit.edu:/pub/gnu/regex-0.12.tar.gz}. For a description of
+regular expressions, @xref{syntax, , , regex, "regex" regular expression
+matching library}.
+
+@defun regcomp @var{pattern} [@var{flags}]
+Compile a @dfn{regular expression}. Return a compiled regular
+expression, or an integer error code suitable as an argument to
+@code{regerror}.
+
+@var{flags} in @code{regcomp} is a string of option letters used to
+control the compilation of the regular expression. The letters may
+consist of:
+
+@table @samp
+@item n
+newlines won't be matched by @code{.} or hat lists; ( @code{[^...]} )
+@item i
+ignore case.
+@exdent only when compiled with @var{_GNU_SOURCE}:
+@item 0
+allows dot to match a null character.
+@item f
+enable GNU fastmaps.
+@end table
+@end defun
+
+@defun regerror @var{errno}
+Returns a string describing the integer @var{errno} returned when
+@code{regcomp} fails.
+@end defun
+
+@defun regexec @var{re} @var{string}
+Returns @code{#f} or a vector of integers. These integers are in
+doublets. The first of each doublet is the index of @var{string} of
+the start of the matching expression or sub-expression (delimited by
+parentheses in the pattern). The last of each doublet is index of
+@var{string} of the end of that expression. @code{#f} is returned if
+the string does not match.
+@end defun
+
+@defun regmatch? @var{re} @var{string}
+Returns @code{#t} if the @var{pattern} such that @var{regexp} = (regcomp
+@var{pattern}) matches @var{string} as a POSIX extended regular
+expressions. Returns @code{#f} otherwise.
+@end defun
+
+@defun regsearch @var{re} @var{string} [@var{start} [@var{len}]]
+@defunx regsearchv @var{re} @var{string} [@var{start} [@var{len}]]
+@defunx regmatch @var{re} @var{string} [@var{start} [@var{len}]]
+@defunx regmatchv @var{re} @var{string} [@var{start} [@var{len}]]
+@code{Regsearch} searches for the pattern within the string.
+
+@code{Regmatch} anchors the pattern and begins matching it against
+string.
+
+@code{Regsearch} returns the character position where @var{re} starts,
+or @code{#f} if not found.
+
+@code{Regmatch} returns the number of characters matched, @code{#f} if
+not matched.
+
+@code{Regsearchv} and @code{regmatchv} return the match vector is
+returned if @var{re} is found, @code{#f} otherwise.
+
+@table @var
+@item re
+may be either:
+@enumerate
+@item
+a compiled regular expression returned by @code{regcomp};
+@item
+a string representing a regular expression;
+@item
+a list of a string and a set of option letters.
+@end enumerate
+@item string
+The string to be operated upon.
+@item start
+The character position at which to begin the search or match. If absent,
+the default is zero.
+
+@exdent @emph{Compiled _GNU_SOURCE and using GNU libregex only:}
+
+When searching, if @var{start} is negative, the absolute value of
+@var{start} will be used as the start location and reverse searching
+will be performed.
+
+@item len
+The search is allowed to examine only the first @var{len} characters of
+@var{string}. If absent, the entire string may be examined.
+@end table
+@end defun
+
+@defun string-split @var{re} @var{string}
+@defunx string-splitv @var{re} @var{string}
+@code{String-split} splits a string into substrings that are separated
+by @var{re}, returning a vector of substrings.
+
+@code{String-splitv} returns a vector of string positions that indicate
+where the substrings are located.
+@end defun
+
+@defun string-edit @var{re} @var{edit-spec} @var{string} [@var{count}]
+Returns the edited string.
+
+@table @var
+@item edit-spec
+Is a string used to replace occurances of @var{re}. Backquoted integers
+in the range of 1-9 may be used to insert subexpressions in @var{re}, as
+in @code{sed}.
+@item count
+The number of substitutions for @code{string-edit} to perform. If
+@code{#t}, all occurances of @var{re} will be replaced. The default is
+to perform one substitution.
+@end table
+@end defun
+
+@node Line Editing, Curses, Regular Expression Pattern Matching, Packages
+@section Line Editing
+
+@noindent
+These procedures provide input line editing and recall.
+
+@noindent
+These functions are defined in @file{edline.c} and @file{Iedline.scm}
+using the @dfn{editline} or GNU @dfn{readline} (@pxref{Top, , Overview
+,readline ,GNU Readline Library}) libraries available from:
+
+@itemize @bullet
+@item
+@ifset html
+<A HREF="ftp://ftp.sys.toronto.edu/pub/rc/editline.shar">
+@end ifset
+@code{ftp.sys.toronto.edu:/pub/rc/editline.shar}
+@ifset html
+</A>
+@end ifset
+@item
+@ifset html
+<A HREF="ftp://prep.ai.mit.edu/pub/gnu/readline-2.0.tar.gz">
+@end ifset
+@code{prep.ai.mit.edu:/pub/gnu/readline-2.0.tar.gz}
+@ifset html
+</A>
+@end ifset
+@end itemize
+
+@noindent
+When @file{Iedline.scm} is loaded, if the current input port is the
+default input port and the environment variable @var{EMACS} is not
+defined, line-editing mode will be entered.
+
+@defun default-input-port
+Returns the initial @code{current-input-port} SCM was invoked with
+(stdin).
+@end defun
+
+@defun default-output-port
+Returns the initial @code{current-output-port} SCM was invoked with
+(stdout).
+@end defun
+
+@defun make-edited-line-port
+Returns an input/output port that allows command line editing and
+retrieval of history.
+@end defun
+
+@defun line-editing
+Returns the current edited line port or @code{#f}.
+
+@defunx line-editing bool
+If @var{bool} is false, exits line-editing mode and returns the previous
+value of @code{(line-editing)}. If @var{bool} is true, sets the current
+input and output ports to an edited line port and returns the previous
+value of @code{(line-editing)}.
+@end defun
+
+@node Curses, Sockets, Line Editing, Packages
+@section Curses
+
+@noindent
+These functions are defined in @file{crs.c} using the @dfn{curses}
+library. Unless otherwise noted these routines return @code{#t} for
+successful completion and @code{#f} for failure.
+
+@defun initscr
+Returns a port for a full screen window. This routine must be called to
+initialize curses.
+@end defun
+
+@defun endwin
+A program should call @code{endwin} before exiting or escaping from
+curses mode temporarily, to do a system call, for example. This routine
+will restore termio modes, move the cursor to the lower left corner of
+the screen and reset the terminal into the proper non-visual mode. To
+resume after a temporary escape, call @ref{Window Manipulation,
+refresh}.
+@end defun
+
+@menu
+* Output Options Setting::
+* Terminal Mode Setting::
+* Window Manipulation::
+* Output::
+* Input::
+* Curses Miscellany::
+@end menu
+
+@node Output Options Setting, Terminal Mode Setting, Curses, Curses
+@subsection Output Options Setting
+
+@noindent
+These routines set options within curses that deal with output. All
+options are initially @code{#f}, unless otherwise stated. It is not
+necessary to turn these options off before calling @code{endwin}.
+
+@defun clearok win bf
+If enabled (@var{bf} is @code{#t}), the next call to @code{force-output}
+or @code{refresh} with @var{win} will clear the screen completely and
+redraw the entire screen from scratch. This is useful when the contents
+of the screen are uncertain, or in some cases for a more pleasing visual
+effect.
+@end defun
+
+@defun idlok win bf
+If enabled (@var{bf} is @code{#t}), curses will consider using the
+hardware ``insert/delete-line'' feature of terminals so equipped. If
+disabled (@var{bf} is @code{#f}), curses will very seldom use this
+feature. The ``insert/delete-character'' feature is always considered.
+This option should be enabled only if your application needs
+``insert/delete-line'', for example, for a screen editor. It is
+disabled by default because
+
+``insert/delete-line'' tends to be visually annoying when used in
+applications where it is not really needed. If ``insert/delete-line''
+cannot be used, curses will redraw the changed portions of all lines.
+@end defun
+
+@defun leaveok win bf
+Normally, the hardware cursor is left at the location of the window
+cursor being refreshed. This option allows the cursor to be left
+wherever the update happens to leave it. It is useful for
+applications where the cursor is not used, since it reduces the need
+for cursor motions. If possible, the cursor is made invisible when
+this option is enabled.
+@end defun
+
+@defun scrollok win bf
+This option controls what happens when the cursor of window @var{win} is
+moved off the edge of the window or scrolling region, either from a
+newline on the bottom line, or typing the last character of the last
+line. If disabled (@var{bf} is @code{#f}), the cursor is left on the
+bottom line at the location where the offending character was entered.
+If enabled (@var{bf} is @code{#t}), @code{force-output} is called on the
+window @var{win}, and then the physical terminal and window @var{win}
+are scrolled up one line.
+
+@emph{Note:} in order to get the physical scrolling effect on the
+terminal, it is also necessary to call @code{idlok}.
+@end defun
+
+@defun nodelay win bf
+This option causes wgetch to be a non-blocking call. If no input is
+ready, wgetch will return an eof-object. If disabled, wgetch will hang
+until a key is pressed.
+@end defun
+
+@node Terminal Mode Setting, Window Manipulation, Output Options Setting, Curses
+@subsection Terminal Mode Setting
+
+@noindent
+These routines set options within curses that deal with input. The
+options involve using ioctl(2) and therefore interact with curses
+routines. It is not necessary to turn these options off before
+calling @code{endwin}. The routines in this section all return an
+unspecified value.
+
+@defun cbreak
+@defunx nocbreak
+These two routines put the terminal into and out of @code{CBREAK} mode,
+respectively. In @code{CBREAK} mode, characters typed by the user are
+immediately available to the program and erase/kill character
+processing is not performed. When in @code{NOCBREAK} mode, the tty driver
+will buffer characters typed until a @key{LFD} or @key{RET} is typed.
+Interrupt and flowcontrol characters are unaffected by this mode.
+Initially the terminal may or may not be in @code{CBREAK} mode, as it is
+inherited, therefore, a program should call @code{cbreak} or @code{nocbreak}
+explicitly. Most interactive programs using curses will set @code{CBREAK}
+mode.
+
+@emph{Note:} @code{cbreak} overrides @code{raw}. For a discussion of
+how these routines interact with @code{echo} and @code{noecho}
+@xref{Input, read-char}.
+@end defun
+
+@defun raw
+@defunx noraw
+The terminal is placed into or out of @code{RAW} mode. @code{RAW} mode
+is similar to @code{CBREAK} mode, in that characters typed are
+immediately passed through to the user program. The differences are
+that in @code{RAW} mode, the interrupt, quit, suspend, and flow control
+characters are passed through uninterpreted, instead of generating a
+signal. @code{RAW} mode also causes 8-bit input and output. The
+behavior of the @code{BREAK} key depends on other bits in the terminal
+driver that are not set by curses.
+@end defun
+
+@defun echo
+@defunx noecho
+These routines control whether characters typed by the user are echoed
+by @code{read-char} as they are typed. Echoing by the tty driver is
+always disabled, but initially @code{read-char} is in @code{ECHO} mode,
+so characters typed are echoed. Authors of most interactive programs
+prefer to do their own echoing in a controlled area of the screen, or
+not to echo at all, so they disable echoing by calling @code{noecho}.
+For a discussion of how these routines interact with @code{echo} and
+@code{noecho} @xref{Input, read-char}.
+@end defun
+
+@defun nl
+@defunx nonl
+These routines control whether @key{LFD} is translated into @key{RET}
+and @code{LFD} on output, and whether @key{RET} is translated into
+@key{LFD} on input. Initially, the translations do occur. By disabling
+these translations using @code{nonl}, curses is able to make better use
+of the linefeed capability, resulting in faster cursor motion.
+@end defun
+
+@defun resetty
+@defunx savetty
+These routines save and restore the state of the terminal modes.
+@code{savetty} saves the current state of the terminal in a buffer and
+@code{resetty} restores the state to what it was at the last call to
+@code{savetty}.
+@end defun
+
+@node Window Manipulation, Output, Terminal Mode Setting, Curses
+@subsection Window Manipulation
+
+@defun newwin nlines ncols begy begx
+Create and return a new window with the given number of lines (or rows),
+@var{nlines}, and columns, @var{ncols}. The upper left corner of the
+window is at line @var{begy}, column @var{begx}. If either @var{nlines}
+or @var{ncols} is 0, they will be set to the value of
+@code{LINES}-@var{begy} and @code{COLS}-@var{begx}. A new full-screen
+window is created by calling @code{newwin(0,0,0,0)}.
+@end defun
+
+@defun subwin orig nlines ncols begy begx
+Create and return a pointer to a new window with the given number of
+lines (or rows), @var{nlines}, and columns, @var{ncols}. The window is
+at position (@var{begy}, @var{begx}) on the screen. This position is
+relative to the screen, and not to the window @var{orig}. The window is
+made in the middle of the window @var{orig}, so that changes made to one
+window will affect both windows. When using this routine, often it will
+be necessary to call @code{touchwin} or @code{touchline} on @var{orig}
+before calling @code{force-output}.
+@end defun
+
+@defun close-port win
+Deletes the window @var{win}, freeing up all memory associated with it.
+In the case of sub-windows, they should be deleted before the main
+window @var{win}.
+@end defun
+
+@defun refresh
+@defunx force-output win
+These routines are called to write output to the terminal, as most other
+routines merely manipulate data structures. @code{force-output} copies
+the window @var{win} to the physical terminal screen, taking into
+account what is already there in order to minimize the amount of
+information that's sent to the terminal (called optimization). Unless
+@code{leaveok} has been enabled, the physical cursor of the terminal is
+left at the location of window @var{win}'s cursor. With @code{refresh},
+the number of characters output to the terminal is returned.
+@end defun
+
+@defun mvwin win y x
+Move the window @var{win} so that the upper left corner will be at position
+(@var{y}, @var{x}). If the move would cause the window @var{win} to be off the
+screen, it is an error and the window @var{win} is not moved.
+@end defun
+
+@defun overlay srcwin dstwin
+@defunx overwrite srcwin dstwin
+
+These routines overlay @var{srcwin} on top of @var{dstwin}; that is, all
+text in @var{srcwin} is copied into @var{dstwin}. @var{srcwin} and
+@var{dstwin} need not be the same size; only text where the two windows
+overlap is copied. The difference is that @code{overlay} is
+non-destructive (blanks are not copied), while @code{overwrite} is
+destructive.
+@end defun
+
+@defun touchwin win
+@defunx touchline win start count
+Throw away all optimization information about which parts of the window
+@var{win} have been touched, by pretending that the entire window
+@var{win} has been drawn on. This is sometimes necessary when using
+overlapping windows, since a change to one window will affect the other
+window, but the records of which lines have been changed in the other
+window will not reflect the change. @code{touchline} only pretends that
+@var{count} lines have been changed, beginning with line @var{start}.
+@end defun
+
+@defun wmove win y x
+The cursor associated with the window @var{win} is moved to line (row) @var{y},
+column @var{x}. This does not move the physical cursor of the terminal
+until @code{refresh} (or @code{force-output}) is called. The position
+specified is relative to the upper left corner of the window @var{win},
+which is (0, 0).
+@end defun
+
+@node Output, Input, Window Manipulation, Curses
+@subsection Output
+
+@noindent
+These routines are used to @dfn{draw} text on windows
+
+@defun display ch win
+@defunx display str win
+@defunx wadd win ch
+@defunx wadd win str
+The character @var{ch} or characters in @var{str} are put into the
+window @var{win} at the current cursor position of the window and the
+position of @var{win}'s cursor is advanced. At the right margin, an
+automatic newline is performed. At the bottom of the scrolling region,
+if scrollok is enabled, the scrolling region will be scrolled up one
+line.
+
+If @var{ch} is a @key{TAB}, @key{LFD}, or backspace, the cursor will be
+moved appropriately within the window @var{win}. A @key{LFD} also does a
+@code{wclrtoeol} before moving. @key{TAB} characters are considered to
+be at every eighth column. If @var{ch} is another control character, it
+will be drawn in the @kbd{C-x} notation. (Calling @code{winch} after
+adding a control character will not return the control character, but
+instead will return the representation of the control character.)
+
+Video attributes can be combined with a character by or-ing them into
+the parameter. This will result in these attributes also being set.
+The intent here is that text, including attributes, can be copied from
+one place to another using inch and display. See @code{standout},
+below.
+
+@emph{Note:} For @code{wadd} @var{ch} can be an integer and will insert
+the character of the corresponding value.
+@end defun
+
+@defun werase win
+This routine copies blanks to every position in the window @var{win}.
+@end defun
+
+@defun wclear win
+This routine is like @code{werase}, but it also calls @ref{Output
+Options Setting, clearok}, arranging that the screen will be cleared
+completely on the next call to @code{refresh} or @code{force-output} for
+window @var{win}, and repainted from scratch.
+@end defun
+
+@defun wclrtobot win
+All lines below the cursor in window @var{win} are erased. Also, the
+current line to the right of the cursor, inclusive, is erased.
+@end defun
+
+@defun wclrtoeol win
+The current line to the right of the cursor, inclusive, is erased.
+@end defun
+
+@defun wdelch win
+The character under the cursor in the window @var{win} is deleted. All
+characters to the right on the same line are moved to the left one
+position and the last character on the line is filled with a blank. The
+cursor position does not change. This does not imply use of the
+hardware ``delete-character'' feature.
+@end defun
+
+@defun wdeleteln win
+The line under the cursor in the window @var{win} is deleted. All lines
+below the current line are moved up one line. The bottom line @var{win}
+is cleared. The cursor position does not change. This does not imply
+use of the hardware ``deleteline'' feature.
+@end defun
+
+@defun winsch win ch
+The character @var{ch} is inserted before the character under the
+cursor. All characters to the right are moved one @key{SPC} to the
+right, possibly losing the rightmost character of the line. The cursor
+position does not change . This does not imply use of the hardware
+``insertcharacter'' feature.
+@end defun
+
+@defun winsertln win
+A blank line is inserted above the current line and the bottom line is
+lost. This does not imply use of the hardware ``insert-line'' feature.
+@end defun
+
+@defun scroll win
+The window @var{win} is scrolled up one line. This involves moving the
+lines in @var{win}'s data structure. As an optimization, if @var{win}
+is stdscr and the scrolling region is the entire window, the physical
+screen will be scrolled at the same time.
+@end defun
+
+@node Input, Curses Miscellany, Output, Curses
+@subsection Input
+
+@defun read-char win
+A character is read from the terminal associated with the window
+@var{win}. Depending on the setting of @code{cbreak}, this will be
+after one character (@code{CBREAK} mode), or after the first newline
+(@code{NOCBREAK} mode). Unless @code{noecho} has been set, the
+character will also be echoed into @var{win}.
+
+When using @code{read-char}, do not set both @code{NOCBREAK} mode
+(@code{nocbreak}) and @code{ECHO} mode (@code{echo}) at the same time.
+Depending on the state of the terminal driver when each character is
+typed, the program may produce undesirable results.
+@end defun
+
+@defun winch win
+The character, of type chtype, at the current position in window
+@var{win} is returned. If any attributes are set for that position,
+their values will be OR'ed into the value returned.
+@end defun
+
+@defun getyx win
+A list of the y and x coordinates of the cursor position of the window
+@var{win} is returned
+@end defun
+
+@node Curses Miscellany, , Input, Curses
+@subsection Curses Miscellany
+
+@defun wstandout win
+@defunx wstandend win
+
+These functions set the current attributes of the window @var{win}. The
+current attributes of @var{win} are applied to all characters that are
+written into it. Attributes are a property of the character, and move
+with the character through any scrolling and insert/delete
+line/character operations. To the extent possible on the particular
+terminal, they will be displayed as the graphic rendition of characters
+put on the screen.
+
+@code{wstandout} sets the current attributes of the window @var{win} to
+be visibly different from other text. @code{wstandend} turns off the
+attributes.
+@end defun
+
+@defun box win vertch horch
+A box is drawn around the edge of the window @var{win}. @var{vertch}
+and @var{horch} are the characters the box is to be drawn with. If
+@var{vertch} and @var{horch} are 0, then appropriate default characters,
+@code{ACS_VLINE} and @code{ACS_HLINE}, will be used.
+
+@emph{Note:} @var{vertch} and @var{horch} can be an integers and will
+insert the character (with attributes) of the corresponding values.
+@end defun
+
+@defun unctrl c
+This macro expands to a character string which is a printable
+representation of the character @var{c}. Control characters are
+displayed in the @kbd{C-x} notation. Printing characters are displayed
+as is.
+@end defun
+
+@node Sockets, , Curses, Packages
+@section Sockets
+
+@noindent
+These procedures (defined in @file{socket.c}) provide a Scheme interface
+to most of the C @dfn{socket} library. For more information on sockets,
+@xref{Sockets, , , libc, The GNU C Library Reference Manual}.
+
+@menu
+* Host Data::
+* Internet Addresses and Socket Names::
+* Socket::
+@end menu
+
+@node Host Data, Internet Addresses and Socket Names, Sockets, Sockets
+@subsection Host Data, Network, Protocol, and Service Inquiries
+
+@defvr Constant af_inet
+@defvrx Constant af_unix
+Integer family codes for Internet and Unix sockets, respectively.
+@end defvr
+
+@defun gethost host-spec
+@defunx gethost
+Returns a vector of information for the entry for @code{HOST-SPEC} or the
+next entry if @code{HOST-SPEC} isn't given. The information is:
+
+@enumerate 0
+@item
+host name string
+@item
+list of host aliases strings
+@item
+integer address type (@code{AF_INET})
+@item
+integer size of address entries (in bytes)
+@item
+list of integer addresses
+@end enumerate
+@end defun
+
+@defun sethostent stay-open
+@defunx sethostent
+Rewinds the host entry table back to the begining if given an argument.
+If the argument @var{stay-open} is @code{#f} queries will be be done
+using @code{UDP} datagrams. Otherwise, a connected @code{TCP} socket
+will be used. When called without an argument, the host table is
+closed.
+@end defun
+
+@defun getnet name-or-number
+@defunx getnet
+Returns a vector of information for the entry for @var{name-or-number} or
+the next entry if an argument isn't given. The information is:
+
+@enumerate 0
+@item
+official network name string
+@item
+list of network aliases strings
+@item
+integer network address type (@code{AF_INET})
+@item
+integer network number
+@end enumerate
+@end defun
+
+@defun setnetent stay-open
+@defunx setnetent
+Rewinds the network entry table back to the begining if given an
+argument. If the argument @var{stay-open} is @code{#f} the table will be closed
+between calls to getnet. Otherwise, the table stays open. When
+called without an argument, the network table is closed.
+@end defun
+
+@defun getproto name-or-number
+@defunx getproto
+Returns a vector of information for the entry for @var{name-or-number} or
+the next entry if an argument isn't given. The information is:
+
+@enumerate
+@item
+official protocol name string
+@item
+list of protocol aliases strings
+@item
+integer protocol number
+@end enumerate
+@end defun
+
+@defun setprotoent stay-open
+@defunx setprotoent
+Rewinds the protocol entry table back to the begining if given an
+argument. If the argument @var{stay-open} is @code{#f} the table will be closed
+between calls to getproto. Otherwise, the table stays open. When
+called without an argument, the protocol table is closed.
+@end defun
+
+@defun getserv name-or-port-number protocol
+@defunx getserv
+Returns a vector of information for the entry for @var{name-or-port-number}
+and @var{protocol} or the next entry if arguments aren't given. The
+information is:
+
+@enumerate 0
+@item
+official service name string
+@item
+list of service aliases strings
+@item
+integer port number
+@item
+protocol
+@end enumerate
+@end defun
+
+@defun setservent stay-open
+@defunx setservent
+Rewinds the service entry table back to the begining if given an
+argument. If the argument @var{stay-open} is @code{#f} the table will be closed
+between calls to getserv. Otherwise, the table stays open. When
+called without an argument, the service table is closed.
+@end defun
+
+@node Internet Addresses and Socket Names, Socket, Host Data, Sockets
+@subsection Internet Addresses and Socket Names
+
+@defun inet:string->address string
+Returns the host address number (integer) for host @var{string} or
+@code{#f} if not found.
+@end defun
+
+@defun inet:address->string address
+Converts an internet (integer) address to a string in numbers and dots
+notation. This is an inverse function to inet:address.
+@end defun
+
+@defun inet:network address
+Returns the network number (integer) specified from @var{address} or
+@code{#f} if not found.
+@end defun
+
+@defun inet:local-network-address address
+Returns the integer for the address of @var{address} within its local
+network or @code{#f} if not found.
+@end defun
+
+@defun inet:make-address network local-address
+Returns the Internet address of @var{local-address} in @var{network}.
+@end defun
+
+@noindent
+The type @dfn{socket-name} is used for inquiries about open sockets in
+the following procedures:
+
+@defun getsockname socket
+Returns the socket-name of @var{socket}. Returns @code{#f} if
+unsuccessful or @var{socket} is closed.
+@end defun
+
+@defun getpeername socket
+Returns the socket-name of the socket connected to @var{socket}.
+Returns @code{#f} if unsuccessful or @var{socket} is closed.
+@end defun
+
+@defun socket-name:family socket-name
+Returns the integer code for the family of @var{socket-name}.
+@end defun
+
+@defun socket-name:port-number socket-name
+Returns the integer port number of @var{socket-name}.
+@end defun
+
+@defun socket-name:address socket-name
+Returns the integer Internet address for @var{socket-name}.
+@end defun
+
+
+@node Socket, , Internet Addresses and Socket Names, Sockets
+@subsection Socket
+
+@noindent
+When a port is returned from one of these calls it is unbuffered.
+This allows both reading and writing to the same port to work. If you
+want buffered ports you can (assuming sock-port is a socket i/o port):
+@example
+(require 'i/o-extensions)
+(define i-port (duplicate-port sock-port "r"))
+(define o-port (duplicate-port sock-port "w"))
+@end example
+
+@defun make-stream-socket family
+@defunx make-stream-socket family protocol
+
+Returns a @code{SOCK_STREAM} socket of type @var{family} using
+@var{protocol}. If @var{family} has the value @code{AF_INET},
+@code{SO_REUSEADDR} will be set. The integer argument @var{protocol}
+corresponds to the integer protocol numbers returned (as vector
+elements) from @code{(getproto)}. If the @var{protocol} argument is not
+supplied, the default (0) for the specified @var{family} is used. SCM
+sockets look like ports opened for neither reading nor writing.
+@end defun
+
+@defun make-stream-socketpair family
+@defunx make-stream-socketpair family protocol
+
+Returns a pair (cons) of connected @code{SOCK_STREAM} (socket) ports of
+type @var{family} using @var{protocol}. Many systems support only
+socketpairs of the @code{af-unix} @var{family}. The integer argument
+@var{protocol} corresponds to the integer protocol numbers returned (as
+vector elements) from (getproto). If the @var{protocol} argument is
+not supplied, the default (0) for the specified @var{family} is used.
+@end defun
+
+@defun socket:shutdown socket how
+Makes @var{socket} no longer respond to some or all operations depending on
+the integer argument @var{how}:
+
+@enumerate 0
+@item
+Further input is disallowed.
+@item
+Further output is disallowed.
+@item
+Further input or output is disallowed.
+@end enumerate
+
+@code{Socket:shutdown} returns @var{socket} if successful, @code{#f} if
+not.
+@end defun
+
+@defun socket:connect inet-socket host-number port-number
+@defunx socket:connect unix-socket pathname
+Returns @var{socket} (changed to a read/write port) connected to the
+Internet socket on host @var{host-number}, port @var{port-number} or
+the Unix socket specified by @var{pathname}. Returns @code{#f} if not
+successful.
+@end defun
+
+@defun socket:bind inet-socket port-number
+@defunx socket:bind unix-socket pathname
+Returns @var{inet-socket} bound to the integer @var{port-number} or the
+@var{unix-socket} bound to new socket in the file system at location
+@var{pathname}. Returns @code{#f} if not successful. Binding a
+@var{unix-socket} creates a socket in the file system that must be
+deleted by the caller when it is no longer needed (using
+@code{delete-file}).
+@end defun
+
+@defun socket:listen socket backlog
+The bound (@pxref{Socket, bind}) @var{socket} is readied to
+accept connections. The positive integer @var{backlog} specifies how
+many pending connections will be allowed before further connection
+requests are refused. Returns @var{socket} (changed to a read-only
+port) if successful, @code{#f} if not.
+@end defun
+
+@defun char-ready? listen-socket
+The input port returned by a successful call to @code{socket:listen} can
+be polled for connections by @code{char-ready?} (@pxref{Files and Ports,
+char-ready?}). This avoids blocking on connections by
+@code{socket:accept}.
+@end defun
+
+@defun socket:accept socket
+Accepts a connection on a bound, listening @var{socket}. Returns an
+input/output port for the connection.
+@end defun
+
+@noindent
+The following example is not too complicated, yet shows the use of
+sockets for multiple connections without input blocking.
+
+@example
+;;;; Scheme chat server
+
+;;; This program implements a simple `chat' server which accepts
+;;; connections from multiple clients, and sends to all clients any
+;;; characters received from any client.
+
+;;; To connect to chat `telnet localhost 8001'
+
+(require 'socket)
+(require 'i/o-extensions)
+
+(let ((listener-socket (socket:bind (make-stream-socket af_inet) 8001))
+ (connections '()))
+ (socket:listen listener-socket 5)
+ (do () (#f)
+ (cond ((char-ready? listener-socket)
+ (let ((con (socket:accept listener-socket)))
+ (display "accepting connection from ")
+ (display (getpeername con))
+ (newline)
+ (set! connections (cons con connections))
+ (display "connected" con)
+ (newline con))))
+ (set! connections
+ (let next ((con-list connections))
+ (cond ((null? con-list) '())
+ (else
+ (let ((con (car con-list)))
+ (cond ((char-ready? con)
+ (let ((c (read-char con)))
+ (cond ((eof-object? c)
+ (display "closing connection from ")
+ (display (getpeername con))
+ (newline)
+ (close-port con)
+ (next (cdr con-list)))
+ (else
+ (for-each (lambda (con)
+ (file-set-position con 0)
+ (write-char c con)
+ (file-set-position con 0))
+ connections)
+ (cons con (next (cdr con-list)))))))
+ (else (cons con (next (cdr con-list))))))))))))
+@end example
+
+@noindent
+You can use @samp{telnet localhost 8001} to connect to the chat server,
+or you can use a client written in scheme:
+
+@example
+;;;; Scheme chat client
+
+;;; this program connects to socket 8001. It then sends all
+;;; characters from current-input-port to the socket and sends all
+;;; characters from the socket to current-output-port.
+
+(require 'socket)
+(require 'i/o-extensions)
+
+(define con (make-stream-socket af_inet))
+(set! con (socket:connect con (inet:string->address "localhost") 8001))
+
+(do ((cs #f (and (char-ready? con) (read-char con)))
+ (ct #f (and (char-ready?) (read-char))))
+ ((or (eof-object? cs) (eof-object? ct))
+ (close-port con))
+ (cond (cs (display cs)))
+ (cond (ct (file-set-position con 0)
+ (display ct con)
+ (file-set-position con 0))))
+@end example
+
+
+@node The Implementation, Procedure and Macro Index, Packages, Top
+@chapter The Implementation
+
+@menu
+* Data Types::
+* Operations::
+* Improvements To Make::
+* Finishing Dynamic Linking::
+@end menu
+
+@node Data Types, Operations, The Implementation, The Implementation
+@section Data Types
+
+@noindent
+In the descriptions below it is assumed that @code{long int}s are 32
+bits in length. Acutally, SCM is written to work with any @code{long
+int} size larger than 31 bits. With some modification, SCM could work
+with word sizes as small as 24 bits.
+
+@noindent
+All SCM objects are represented by type @dfn{SCM}. Type @code{SCM} come
+in 2 basic flavors, Immediates and Cells:
+
+@menu
+* Immediates::
+* Cells:: Non-Immediate types
+* Header Cells:: Malloc objects
+* Subr Cells:: Built-in and Compiled Procedures
+* Ptob Cells:: I/O ports
+* Smob Cells:: Miscellaneous datatypes
+* Data Type Representations:: How they all fit together
+@end menu
+
+@node Immediates, Cells, Data Types, Data Types
+@subsection Immediates
+
+@noindent
+An @dfn{immediate} is a data type contained in type @code{SCM}
+(@code{long int}). The type codes distinguishing immediate types from
+each other vary in length, but reside in the low order bits.
+
+@defmac IMP x
+@defmacx NIMP x
+Return non-zero if the @code{SCM} object @var{x} is an immediate or
+non-immediate type, respectively.
+@end defmac
+
+@deftp Immediate inum
+immediate 30 bit signed integer. An INUM is flagged by a @code{1} in
+the second to low order bit position. The high order 30 bits are used
+for the integer's value.
+
+@defmac INUMP x
+@defmacx NINUMP x
+Return non-zero if the @code{SCM} @var{x} is an immediate integer or not
+an immediate integer, respectively.
+@end defmac
+
+@defmac INUM x
+Returns the C @code{long integer} corresponding to @code{SCM} @var{x}.
+@end defmac
+
+@defmac MAKINUM x
+Returns the @code{SCM} inum corresponding to C @code{long integer} x.
+@end defmac
+
+@defvr {Immediate Constant} INUM0
+is equivalent to @code{MAKINUM(0)}.
+@end defvr
+
+Computations on INUMs are performed by converting the arguments to C
+integers (by a shift), operating on the integers, and converting the
+result to an inum. The result is checked for overflow by converting
+back to integer and checking the reverse operation.
+
+The shifts used for conversion need to be signed shifts. If the C
+implementation does not support signed right shift this fact is detected
+in a #if statement in @file{scmfig.h} and a signed right shift,
+@code{SRS}, is constructed in terms of unsigned right shift.
+@end deftp
+
+@deftp Immediate ichr
+characters.
+
+@defmac ICHRP x
+Return non-zero if the @code{SCM} object @var{x} is a character.
+@end defmac
+
+@defmac ICHR x
+Returns corresponding @code{unsigned char}.
+@end defmac
+
+@defmac MAKICHR x
+Given @code{char} @var{x}, returns @code{SCM} character.
+@end defmac
+
+@end deftp
+
+@deftp Immediate iflags
+These are frequently used immediate constants.
+@deftypevr {Immediate Constant} SCM BOOL_T
+@code{#t}
+@end deftypevr
+@deftypevr {Immediate Constant} SCM BOOL_F
+@code{#f}
+@end deftypevr
+@deftypevr {Immediate Constant} SCM EOL
+@code{()}. If @code{SICP} is @code{#define}d, @code{EOL} is
+@code{#define}d to be identical with @code{BOOL_F}. In this case, both
+print as @code{#f}.
+@end deftypevr
+@deftypevr {Immediate Constant} SCM EOF_VAL
+end of file token, @code{#<eof>}.
+@end deftypevr
+@deftypevr {Immediate Constant} SCM UNDEFINED
+@code{#<undefined>} used for variables which have not been defined and
+absent optional arguments.
+@end deftypevr
+@deftypevr {Immediate Constant} SCM UNSPECIFIED
+@code{#<unspecified>} is returned for those procedures whose return
+values are not specified.
+@end deftypevr
+
+@end deftp
+
+@defmac IFLAGP n
+Returns non-zero if @var{n} is an ispcsym, isym or iflag.
+@end defmac
+
+@defmac ISYMP n
+Returns non-zero if @var{n} is an ispcsym or isym.
+@end defmac
+
+@defmac ISYMNUM n
+Given ispcsym, isym, or iflag @var{n}, returns its index in the C array
+@code{isymnames[]}.
+@end defmac
+
+@defmac ISYMCHARS n
+Given ispcsym, isym, or iflag @var{n}, returns its @code{char *}
+representation (from @code{isymnames[]}).
+@end defmac
+
+@defmac MAKSPCSYM n
+Returns @code{SCM} ispcsym @var{n}.
+@end defmac
+
+@defmac MAKISYM n
+Returns @code{SCM} iisym @var{n}.
+@end defmac
+
+@defmac MAKIFLAG n
+Returns @code{SCM} iflag @var{n}.
+@end defmac
+
+@defvar isymnames
+An array of strings containing the external representations of all the
+ispcsym, isym, and iflag immediates. Defined in @file{repl.c}.
+@end defvar
+
+@defvr Constant NUM_ISPCSYM
+@defvrx Constant NUM_ISYMS
+The number of ispcsyms and ispcsyms+isyms, respectively. Defined in
+@file{scm.h}.
+@end defvr
+
+@deftp Immediate isym
+@code{and}, @code{begin}, @code{case}, @code{cond}, @code{define},
+@code{do}, @code{if}, @code{lambda}, @code{let}, @code{let*},
+@code{letrec}, @code{or}, @code{quote}, @code{set!}, @code{#f},
+@code{#t}, @code{#<undefined>}, @code{#<eof>}, @code{()}, and
+@code{#<unspecified>}.
+
+@deftpx {CAR Immediate} ispcsym
+special symbols: syntax-checked versions of first 14 isyms
+@end deftp
+
+@deftp {CAR Immediate} iloc
+indexes to a variable's location in environment
+@end deftp
+
+@deftp {CAR Immediate} gloc
+pointer to a symbol's value cell
+@end deftp
+
+@deftp Immediate CELLPTR
+pointer to a cell (not really an immediate type, but here for
+completeness). Since cells are always 8 byte aligned, a pointer to a
+cell has the low order 3 bits @code{0}.
+
+There is one exception to this rule, @emph{CAR Immediate}s, described
+next.
+@end deftp
+
+@noindent
+A @dfn{CAR Immediate} is an Immediate point which can only occur in the
+@code{CAR}s of evaluated code (as a result of @code{ceval}'s memoization
+process).
+
+@node Cells, Header Cells, Immediates, Data Types
+@subsection Cells
+
+@noindent
+@dfn{Cell}s represent all SCM objects other than immediates. A cell has
+a @code{CAR} and a @code{CDR}. Low-order bits in @code{CAR} identify
+the type of object. The rest of @code{CAR} and @code{CDR} hold object
+data. The number after @code{tc} specifies how many bits are in the
+type code. For instance, @code{tc7} indicates that the type code is 7
+bits.
+
+@defmac NEWCELL x
+Allocates a new cell and stores a pointer to it in @code{SCM} local
+variable @var{x}.
+
+Care needs to be taken that stores into the new cell pointed to by
+@var{x} do not create an inconsistent object. @xref{Signals}.
+@end defmac
+
+@noindent
+All of the C macros decribed in this section assume that their argument
+is of type @code{SCM} and points to a cell (@code{CELLPTR}).
+
+@defmac CAR x
+@defmacx CDR x
+Returns the @code{car} and @code{cdr} of cell @var{x}, respectively.
+@end defmac
+
+@defmac TYP3 x
+@defmacx TYP7 x
+@defmacx TYP16 x
+Returns the 3, 7, and 16 bit type code of a cell.
+@end defmac
+
+@deftp Cell tc3_cons
+scheme cons-cell returned by (cons arg1 arg2).
+
+@defmac CONSP x
+@defmacx NCONSP x
+Returns non-zero if @var{x} is a @code{tc3_cons} or isn't, respectively.
+@end defmac
+@end deftp
+
+@deftp Cell tc3_closure
+applicable object returned by (lambda (args) @dots{}).
+@code{tc3_closure}s have a pointer to other the body of the procedure in
+the @code{CAR} and a pointer to the environment in the @code{CDR}.
+
+@defmac CLOSUREP x
+Returns non-zero if @var{x} is a @code{tc3_closure}.
+@end defmac
+
+@defmac CODE x
+@defmacx ENV x
+Returns the code body or environment of closure @var{x}, respectively.
+@end defmac
+
+@end deftp
+
+@node Header Cells, Subr Cells, Cells, Data Types
+@subsection Header Cells
+
+@noindent
+@dfn{Header}s are Cells whose @code{CDR}s point elsewhere in memory,
+such as to memory allocated by @code{malloc}.
+
+@deftp Header spare
+spare @code{tc7} type code
+@end deftp
+
+@deftp Header tc7_vector
+scheme vector.
+
+@defmac VECTORP x
+@defmacx NVECTORP x
+Returns non-zero if @var{x} is a @code{tc7_vector} or if not, respectively.
+@end defmac
+
+@defmac VELTS x
+@defmacx LENGTH x
+Returns the C array of @code{SCM}s holding the elements of vector
+@var{x} or its length, respectively.
+@end defmac
+@end deftp
+
+@deftp Header tc7_ssymbol
+static scheme symbol (part of initial system)
+
+@deftpx Header tc7_msymbol
+@code{malloc}ed scheme symbol (can be GCed)
+
+@defmac SYMBOLP x
+Returns non-zero if @var{x} is a @code{tc7_ssymbol} or
+@code{tc7_msymbol}.
+@end defmac
+
+@defmac CHARS x
+@defmacx UCHARS x
+@defmacx LENGTH x
+Returns the C array of @code{char}s or as @code{unsigned char}s holding
+the elements of symbol @var{x} or its length, respectively.
+@end defmac
+@end deftp
+
+@deftp Header tc7_string
+scheme string
+
+@defmac STRINGP x
+@defmacx NSTRINGP x
+Returns non-zero if @var{x} is a @code{tc7_string} or isn't,
+respectively.
+@end defmac
+
+@defmac CHARS x
+@defmacx UCHARS x
+@defmacx LENGTH x
+Returns the C array of @code{char}s or as @code{unsigned char}s holding
+the elements of string @var{x} or its length, respectively.
+@end defmac
+@end deftp
+
+@deftp Header tc7_bvect
+uniform vector of booleans (bit-vector)
+@end deftp
+
+@deftp Header tc7_ivect
+uniform vector of integers
+@end deftp
+
+@deftp Header tc7_uvect
+uniform vector of non-negative integers
+@end deftp
+
+@deftp Header tc7_fvect
+uniform vector of short inexact real numbers
+@end deftp
+
+@deftp Header tc7_dvect
+uniform vector of double precision inexact real numbers
+@end deftp
+
+@deftp Header tc7_cvect
+uniform vector of double precision inexact complex numbers
+@end deftp
+
+@deftp Header tc7_contin
+applicable object produced by call-with-current-continuation
+@end deftp
+
+@deftp Header tc7_cclo
+Subr and environment for compiled closure
+
+A cclo is similar to a vector (and is GCed like one), but can be applied
+as a function:
+
+@enumerate
+@item
+the cclo itself is consed onto the head of the argument list
+@item
+the first element of the cclo is applied to that list. Cclo invocation
+is currently not tail recursive when given 2 or more arguments.
+@end enumerate
+
+@defun makcclo proc len
+makes a closure from the @emph{subr} @var{proc} with @var{len}-1 extra
+locations for @code{SCM} data. Elements of a @var{cclo} are referenced
+using @code{VELTS(cclo)[n]} just as for vectors.
+@end defun
+@end deftp
+
+@node Subr Cells, Ptob Cells, Header Cells, Data Types
+@subsection Subr Cells
+
+@noindent
+A @dfn{Subr} is a header whose @code{CDR} points to a C code procedure.
+Scheme primitive procedures are subrs. Except for the arithmetic
+@code{tc7_cxr}s, the C code procedures will be passed arguments (and
+return results) of type @code{SCM}.
+
+@deftp Subr tc7_asubr
+associative C function of 2 arguments. Examples are @code{+}, @code{-},
+@code{*}, @code{/}, @code{max}, and @code{min}.
+@end deftp
+
+@deftp Subr tc7_subr_0
+C function of no arguments.
+@end deftp
+
+@deftp Subr tc7_subr_1
+C function of one argument.
+@end deftp
+
+@deftp Subr tc7_cxr
+These subrs are handled specially. If inexact numbers are enabled, the
+@code{CDR} should be a function which takes and returns type
+@code{double}. Conversions are handled in the interpreter.
+
+@code{floor}, @code{ceiling}, @code{truncate}, @code{round},
+@code{$sqrt}, @code{$abs}, @code{$exp}, @code{$log}, @code{$sin},
+@code{$cos}, @code{$tan}, @code{$asin}, @code{$acos}, @code{$atan},
+@code{$sinh}, @code{$cosh}, @code{$tanh}, @code{$asinh}, @code{$acosh},
+@code{$atanh}, and @code{exact->inexact} are defined this way.
+
+If the @code{CDR} is @code{0} (@code{NULL}), the name string of the
+procedure is used to control traversal of its list structure argument.
+
+@code{car}, @code{cdr}, @code{caar}, @code{cadr}, @code{cdar},
+@code{cddr}, @code{caaar}, @code{caadr}, @code{cadar}, @code{caddr},
+@code{cdaar}, @code{cdadr}, @code{cddar}, @code{cdddr}, @code{caaaar},
+@code{caaadr}, @code{caadar}, @code{caaddr}, @code{cadaar},
+@code{cadadr}, @code{caddar}, @code{cadddr}, @code{cdaaar},
+@code{cdaadr}, @code{cdadar}, @code{cdaddr}, @code{cddaar},
+@code{cddadr}, @code{cdddar}, and @code{cddddr} are defined this way.
+@end deftp
+
+@deftp Subr tc7_subr_3
+C function of 3 arguments.
+@end deftp
+
+@deftp Subr tc7_subr_2
+C function of 2 arguments.
+@end deftp
+
+@deftp Subr tc7_rpsubr
+transitive relational predicate C function of 2 arguments. The C
+function should return either @code{BOOL_T} or @code{BOOL_F}.
+@end deftp
+
+@deftp Subr tc7_subr_1o
+C function of one optional argument. If the optional argument is not
+present, @code{UNDEFINED} is passed in its place.
+@end deftp
+
+@deftp Subr tc7_subr_2o
+C function of 1 required and 1 optional argument. If the optional
+argument is not present, @code{UNDEFINED} is passed in its place.
+@end deftp
+
+@deftp Subr tc7_lsubr_2
+C function of 2 arguments and a list of (rest of) @code{SCM} arguments.
+@end deftp
+
+@deftp Subr tc7_lsubr
+C function of list of @code{SCM} arguments.
+@end deftp
+
+@node Ptob Cells, Smob Cells, Subr Cells, Data Types
+@subsection Ptob Cells
+
+@noindent
+A @dfn{ptob} is a port object, capable of delivering or accepting
+characters. @xref{Ports, , , r4rs, Revised(4) Report on the Algorithmic
+Language Scheme}. Unlike the types described so far, new varieties of
+ptobs can be defined dynamically (@pxref{Defining Ptobs}). These are
+the initial ptobs:
+
+@deftp ptob tc16_inport
+input port.
+@end deftp
+
+@deftp ptob tc16_outport
+output port.
+@end deftp
+
+@deftp ptob tc16_ioport
+input-output port.
+@end deftp
+
+@deftp ptob tc16_inpipe
+input pipe created by @code{popen()}.
+@end deftp
+
+@deftp ptob tc16_outpipe
+output pipe created by @code{popen()}.
+@end deftp
+
+@deftp ptob tc16_strport
+String port created by @code{cwos()} or @code{cwis()}.
+@end deftp
+
+@deftp ptob tc16_sfport
+Software (virtual) port created by @code{mksfpt()} (@pxref{Soft Ports}).
+@end deftp
+
+@defmac PORTP x
+@defmacx OPPORTP x
+@defmacx OPINPORTP x
+@defmacx OPOUTPORTP x
+@defmacx INPORTP x
+@defmacx OUTPORTP x
+Returns non-zero if @var{x} is a port, open port, open input-port, open
+output-port, input-port, or output-port, respectively.
+@end defmac
+
+@defmac OPENP x
+@defmacx CLOSEDP x
+Returns non-zero if port @var{x} is open or closed, respectively.
+@end defmac
+
+@defmac STREAM x
+Returns the @code{FILE *} stream for port @var{x}.
+@end defmac
+
+@noindent
+Ports which are particularly well behaved are called @dfn{fport}s.
+Advanced operations like @code{file-position} and @code{reopen-file}
+only work for fports.
+
+@defmac FPORTP x
+@defmacx OPFPORTP x
+@defmacx OPINFPORTP x
+@defmacx OPOUTFPORTP x
+Returns non-zero if @var{x} is a port, open port, open input-port, or
+open output-port, respectively.
+@end defmac
+
+@node Smob Cells, Data Type Representations, Ptob Cells, Data Types
+@subsection Smob Cells
+
+@noindent
+A @dfn{smob} is a miscellaneous datatype. The type code and GCMARK bit
+occupy the lower order 16 bits of the @code{CAR} half of the cell. The
+rest of the @code{CAR} can be used for sub-type or other information.
+The @code{CDR} contains data of size long and is often a pointer to
+allocated memory.
+
+@noindent
+Like ptobs, new varieties of smobs can be defined dynamically
+(@pxref{Defining Smobs}). These are the initial smobs:
+
+@deftp smob tc_free_cell
+unused cell on the freelist.
+@end deftp
+
+@deftp smob tc16_flo
+single-precision float.
+
+Inexact number data types are subtypes of type @code{tc16_flo}. If the
+sub-type is:
+
+@enumerate 0
+@item
+a single precision float is contained in the @code{CDR}.
+@item
+@code{CDR} is a pointer to a @code{malloc}ed double.
+@end enumerate
+@enumerate 3
+@item
+@code{CDR} is a pointer to a @code{malloc}ed pair of doubles.
+@end enumerate
+
+@deftp smob tc_dblr
+double-precision float.
+@end deftp
+
+@deftp smob tc_dblc
+double-precision complex.
+@end deftp
+@end deftp
+
+@deftp smob tc16_bigpos
+@deftpx smob tc16_bigneg
+positive and negative bignums, respectively.
+
+Scm has large precision integers called bignums. They are stored in
+sign-magnitude form with the sign occuring in the type code of the SMOBs
+bigpos and bigneg. The magnitude is stored as a @code{malloc}ed array
+of type @code{BIGDIG} which must be an unsigned integral type with size
+smaller than @code{long}. @code{BIGRAD} is the radix associated with
+@code{BIGDIG}.
+@end deftp
+
+@deftp smob tc16_promise
+made by DELAY. @xref{Control features, , , r4rs, Revised(4) Scheme}.
+@end deftp
+
+@deftp smob tc16_arbiter
+synchronization object. @xref{Process Synchronization}.
+@end deftp
+
+@deftp smob tc16_macro
+macro expanding function. @xref{Low Level Syntactic Hooks}.
+@end deftp
+
+@deftp smob tc16_array
+multi-dimensional array. @xref{Arrays}.
+
+This type implements both conventional arrays (those with arbitrary data
+as elements @pxref{Conventional Arrays}) and uniform arrays (those with
+elements of a uniform type @pxref{Uniform Array}).
+
+Conventional Arrays have a pointer to a vector for their @code{CDR}.
+Uniform Arrays have a pointer to a Uniform Vector type (string, bvect,
+ivect, uvect, fvect, dvect, or cvect) in their @code{CDR}.
+@end deftp
+
+
+@node Data Type Representations, , Smob Cells, Data Types
+@subsection Data Type Representations
+
+@format
+@r{IMMEDIATE: B,D,E,F=data bit, C=flag code, P=pointer address bit}
+@t{ ................................
+inum BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB10
+ichr BBBBBBBBBBBBBBBBBBBBBBBB11110100
+iflag CCCCCCC101110100
+isym CCCCCCC001110100}
+@r{ IMCAR: only in car of evaluated code, cdr has cell's GC bit}
+@t{ispcsym 000CCCC00CCCC100
+iloc 0DDDDDDDDDDDDDDDEFFFFFFF11111100
+pointer PPPPPPPPPPPPPPPPPPPPPPPPPPPPP000
+gloc PPPPPPPPPPPPPPPPPPPPPPPPPPPPP001}
+
+@r{ HEAP CELL: G=gc_mark; 1 during mark, 0 other times.
+ 1s and 0s here indicate type. G missing means sys (not GC'd)
+ SIMPLE:}
+@t{cons ..........SCM car..............0 ...........SCM cdr.............G
+closure ..........SCM code...........011 ...........SCM env.............G
+ HEADERs:
+ssymbol .........long length....G0000101 ..........char *chars...........
+msymbol .........long length....G0000111 ..........char *chars...........
+string .........long length....G0001101 ..........char *chars...........
+vector .........long length....G0001111 ...........SCM **elts...........
+bvect .........long length....G0010101 ..........long *words...........
+ spare G0010111
+ivect .........long length....G0011101 ..........long *words...........
+uvect .........long length....G0011111 ......unsigned long *words......
+ spare G0100101
+ spare G0100111
+fvect .........long length....G0101101 .........float *words...........
+dvect .........long length....G0101111 ........double *words...........
+cvect .........long length....G0110101 ........double *words...........
+
+contin .........long length....G0111101 .............*regs..............
+cclo .........long length....G0111111 ...........SCM **elts...........}
+@r{ SUBRs:}
+@t{ spare 010001x1
+ spare 010011x1
+subr_0 ..........int hpoff.....01010101 ...........SCM (*f)()...........
+subr_1 ..........int hpoff.....01010111 ...........SCM (*f)()...........
+cxr ..........int hpoff.....01011101 .........double (*f)()..........
+subr_3 ..........int hpoff.....01011111 ...........SCM (*f)()...........
+subr_2 ..........int hpoff.....01100101 ...........SCM (*f)()...........
+asubr ..........int hpoff.....01100111 ...........SCM (*f)()...........
+subr_1o ..........int hpoff.....01101101 ...........SCM (*f)()...........
+subr_2o ..........int hpoff.....01101111 ...........SCM (*f)()...........
+lsubr_2 ..........int hpoff.....01110101 ...........SCM (*f)()...........
+lsubr_2n..........int hpoff.....01110111 ...........SCM (*f)()...........
+rpsubr ..........int hpoff.....01111101 ...........SCM (*f)()...........}
+@r{ PTOBs:}
+@t{ port 0bwroxxxxxxxxG1110111 ..........FILE *stream..........
+ socket ttttttt 00001xxxxxxxxG1110111 ..........FILE *stream..........
+ inport uuuuuuuuuuU00011xxxxxxxxG1110111 ..........FILE *stream..........
+outport 0000000000000101xxxxxxxxG1110111 ..........FILE *stream..........
+ ioport uuuuuuuuuuU00111xxxxxxxxG1110111 ..........FILE *stream..........
+fport 00 00000000G1110111 ..........FILE *stream..........
+pipe 00 00000001G1110111 ..........FILE *stream..........
+strport 00 00000010G1110111 ..........FILE *stream..........
+sfport 00 00000011G1110111 ..........FILE *stream..........}
+@r{ SMOBs:}
+@t{free_cell
+ 000000000000000000000000G1111111 ...........*free_cell........000
+flo 000000000000000000000001G1111111 ...........float num............
+dblr 000000000000000100000001G1111111 ..........double *real..........
+dblc 000000000000001100000001G1111111 .........complex *cmpx..........
+bignum ...int length...0000001 G1111111 .........short *digits..........
+bigpos ...int length...00000010G1111111 .........short *digits..........
+bigneg ...int length...00000011G1111111 .........short *digits..........
+ xxxxxxxx = code assigned by newsmob();
+promise 000000000000000fxxxxxxxxG1111111 ...........SCM val..............
+arbiter 000000000000000lxxxxxxxxG1111111 ...........SCM name.............
+macro 000000000000000mxxxxxxxxG1111111 ...........SCM name.............
+array ...short rank..cxxxxxxxxG1111111 ............*array..............}
+@end format
+
+@node Operations, Improvements To Make, Data Types, The Implementation
+@section Operations
+
+@menu
+* Garbage Collection:: Automatically reclaims unused storage
+* Signals::
+* C Macros::
+* Changing Scm::
+* Defining Subrs::
+* Defining Smobs::
+* Defining Ptobs::
+* Calling Scheme From C::
+* Callbacks::
+* Type Conversions:: For use with C code.
+* Continuations:: For C and SCM
+* Evaluation:: Why SCM is fast
+@end menu
+
+@node Garbage Collection, Signals, Operations, Operations
+@subsection Garbage Collection
+
+The garbage collector is in the latter half of @file{sys.c}. The
+primary goal of @dfn{garbage collection} (or @dfn{GC}) is to recycle
+those cells no longer in use. Immediates always appear as parts of
+other objects, so they are not subject to explicit garbage collection.
+
+All cells reside in the @dfn{heap} (composed of @dfn{heap segments}).
+Note that this is different from what Computer Science usually defines
+as a heap.
+
+@menu
+* Marking Cells::
+* Sweeping the Heap::
+@end menu
+
+@node Marking Cells, Sweeping the Heap, Garbage Collection, Garbage Collection
+@subsubsection Marking Cells
+
+The first step in garbage collection is to @dfn{mark} all heap objects
+in use. Each heap cell has a bit reserved for this purpose. For pairs
+(cons cells) the lowest order bit (0) of the CDR is used. For other
+types, bit 8 of the CAR is used. The GC bits are never set except
+during garbage collection. Special C macros are defined in @file{scm.h}
+to allow easy manipulation when GC bits are possibly set. @code{CAR},
+@code{TYP3}, and @code{TYP7} can be used on GC marked cells as they are.
+
+@defmac GCCDR x
+Returns the CDR of a cons cell, even if that cell has been GC marked.
+@end defmac
+@defmac GCTYP16 x
+Returns the 16 bit type code of a cell.
+@end defmac
+
+We need to (recursively) mark only a few objects in order to assure that
+all accessible objects are marked. Those objects are
+@code{sys_protects[]} (for example, @code{dynwinds}), the current
+C-stack and the hash table for symbols, @dfn{symhash}.
+
+@deftypefun void gc_mark (SCM @var{obj})
+The function @code{gc_mark()} is used for marking SCM cells. If
+@var{obj} is marked, @code{gc_mark()} returns. If @var{obj} is
+unmarked, gc_mark sets the mark bit in @var{obj}, then calls
+@code{gc_mark()} on any SCM components of @var{obj}. The last call to
+@code{gc_mark()} is tail-called (looped).
+@end deftypefun
+
+@deftypefun void mark_locations (STACKITEM @var{x[]}, sizet @var{len}))
+The function @code{mark_locations} is used for marking segments of
+C-stack or saved segments of C-stack (marked continuations). The
+argument @var{len} is the size of the stack in units of size
+@code{(STACKITEM)}.
+
+Each longword in the stack is tried to see if it is a valid cell pointer
+into the heap. If it is, the object itself and any objects it points to
+are marked using @code{gc_mark}. If the stack is word rather than
+longword aligned @code{(#define WORD_ALIGN)}, both alignments are tried.
+This arrangement will occasionally mark an object which is no longer
+used. This has not been a problem in practice and the advantage of
+using the c-stack far outweighs it.
+@end deftypefun
+
+@node Sweeping the Heap, , Marking Cells, Garbage Collection
+@subsubsection Sweeping the Heap
+
+After all found objects have been marked, the heap is swept.
+
+The storage for strings, vectors, continuations, doubles, complexes, and
+bignums is managed by malloc. There is only one pointer to each malloc
+object from its type-header cell in the heap. This allows malloc
+objects to be freed when the associated heap object is garbage
+collected.
+
+@deftypefun static void gc_sweep ()
+The function @code{gc_sweep} scans through all heap segments. The mark
+bit is cleared from marked cells. Unmarked cells are spliced into
+@var{freelist}, where they can again be returned by invocations of
+@code{NEWCELL}.
+
+If a type-header cell pointing to malloc space is unmarked, the malloc
+object is freed. If the type header of smob is collected, the smob's
+@code{free} procedure is called to free its storage.
+@end deftypefun
+
+@node Signals, C Macros, Garbage Collection, Operations
+@subsection Signals
+
+@defun init_signals
+(in @file{scm.c}) initializes handlers for @code{SIGINT} and
+@code{SIGALRM} if they are supported by the C implementation. All of
+the signal handlers immediately reestablish themselves by a call to
+@code{signal()}.
+@end defun
+
+@defun int_signal sig
+@defunx alrm_signal sig
+The low level handlers for @code{SIGINT} and @code{SIGALRM}.
+@end defun
+
+If an interrupt handler is defined when the interrupt is received, the
+code is interpreted. If the code returns, execution resumes from where
+the interrupt happened. @code{Call-with-current-continuation} allows
+the stack to be saved and restored.
+
+SCM does not use any signal masking system calls. These are not a
+portable feature. However, code can run uninterrupted by use of the C
+macros @code{DEFER_INTS} and @code{ALLOW_INTS}.
+
+@defmac DEFER_INTS
+sets the global variable @code{ints_disabled} to 1. If an interrupt
+occurs during a time when @code{ints_disabled} is 1 one of the global
+variables @code{sig_deferred} or @code{alrm_deferred} is set to 1 and
+the handler returns.
+
+@defmacx ALLOW_INTS
+Checks the deferred variables and if set the appropriate handler is
+called.
+
+Calls to @code{DEFER_INTS} can not be nested. An @code{ALLOW_INTS} must
+happen before another @code{DEFER_INTS} can be done. In order to check
+that this constraint is satisfied @code{#define CAREFUL_INTS} in
+@file{scmfig.h}.
+@end defmac
+
+@node C Macros, Changing Scm, Signals, Operations
+@subsection C Macros
+
+
+@defmac ASSERT cond arg pos subr
+signals an error if the expression (@var{cond}) is 0. @var{arg} is the
+offending object, @var{subr} is the string naming the subr, and
+@var{pos} indicates the position or type of error. @var{pos} can be one
+of
+
+@itemize @bullet
+@item @code{ARGn} @i{(> 5 or unknown ARG number)}
+@item @code{ARG1}
+@item @code{ARG2}
+@item @code{ARG3}
+@item @code{ARG4}
+@item @code{ARG5}
+@item @code{WNA} @i{(wrong number of args)}
+@item @code{OVFLOW}
+@item @code{OUTOFRANGE}
+@item @code{NALLOC}
+@item @code{EXIT}
+@item @code{HUP_SIGNAL}
+@item @code{INT_SIGNAL}
+@item @code{FPE_SIGNAL}
+@item @code{BUS_SIGNAL}
+@item @code{SEGV_SIGNAL}
+@item @code{ALRM_SIGNAL}
+@item a C string @code{(char *)}
+@end itemize
+
+Error checking is not done by @code{ASSERT} if the flag @code{RECKLESS}
+is defined. An error condition can still be signaled in this case with
+a call to @code{wta(arg, pos, subr)}.
+@end defmac
+
+@defmac ASRTGO cond label
+@code{goto} @var{label} if the expression (@var{cond}) is 0. Like
+@code{ASSERT}, @code{ASRTGO} does is not active if the flag
+@code{RECKLESS} is defined.
+@end defmac
+
+
+@node Changing Scm, Defining Subrs, C Macros, Operations
+@subsection Changing Scm
+
+@noindent
+When writing C-code for SCM, a precaution is recommended. If your
+routine allocates a non-cons cell which will @emph{not} be incorporated
+into a @code{SCM} object which is returned, you need to make sure that a
+@code{SCM} variable in your routine points to that cell as long as part
+of it might be referenced by your code.
+
+@noindent
+In order to make sure this @code{SCM} variable does not get optimized
+out you can put this assignment after its last possible use:
+
+@example
+SCM_dummy1 = @i{foo};
+@end example
+
+@noindent
+or put this assignment somewhere in your routine:
+
+@example
+SCM_dummy1 = (SCM) &@i{foo};
+@end example
+
+@noindent
+@code{SCM_dummy} variables are not currently defined. Passing the
+address of the local @code{SCM} variable to @emph{any} procedure also
+protects it.
+
+@noindent
+Also, if you maintain a static pointer to some (non-immediate)
+@code{SCM} object, you must either make your pointer be the value cell
+of a symbol (see @code{errobj} for an example) or make your pointer be
+one of the @code{sys_protects} (see @code{dynwinds} for an example).
+The former method is prefered since it does not require any changes to
+the SCM distribution.
+
+@noindent
+To add a C routine to scm:
+
+@enumerate
+@item
+choose the appropriate subr type from the type list.
+@item
+write the code and put into @file{scm.c}.
+@item
+add a @code{make_subr} or @code{make_gsubr} call to @code{init_scm}. Or
+put an entry into the appropriate @code{iproc} structure.
+@end enumerate
+
+To add a package of new procedures to scm (see @file{crs.c} for
+example):
+
+@enumerate
+@item
+create a new C file (@file{@i{foo}.c}).
+@item
+at the front of @file{@i{foo}.c} put declarations for strings for your
+procedure names.
+
+@example
+static char s_twiddle_bits[]="twiddle-bits!";
+static char s_bitsp[]="bits?";
+@end example
+
+@item
+choose the appropriate subr types from the type list in @file{code.doc}.
+@item
+write the code for the procedures and put into @file{@i{foo}.c}
+@item
+create one @code{iproc} structure for each subr type used in @file{@i{foo}.c}
+
+@example
+static iproc subr3s[]= @{
+ @{s_twiddle-bits,twiddle-bits@},
+ @{s_bitsp,bitsp@},
+ @{0,0@} @};
+@end example
+
+@item
+create an @code{init_@i{<name of file>}} routine at the end of the file
+which calls @code{init_iprocs} with the correct type for each of the
+@code{iproc}s created in step 5.
+
+@example
+void init_@i{foo}()
+@{
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr3s, tc7_subr_3);
+@}
+@end example
+
+If your package needs to have a @dfn{finalization} routine called to
+free up storage, close files, etc, then also have a line in
+@code{init_@i{foo}} like:
+
+@example
+add_final(final_@i{foo});
+@end example
+
+@code{final_@i{foo}} should be a (void) procedure of no arguments. The
+finals will be called in opposite order from their definition.
+
+The line:
+
+@example
+add_feature("@i{foo}");
+@end example
+
+will append a symbol @code{'@i{foo}} to the (list) value of
+@code{*features*}.
+@item
+put any scheme code which needs to be run as part of your package into
+@file{I@i{foo}.scm}.
+@item
+put an @code{if} into @file{Init.scm} which loads @file{I@i{foo}.scm} if
+your package is included:
+
+@example
+(if (defined? twiddle-bits!)
+ (load (in-vicinity (implementation-vicinity)
+ "I@i{foo}"
+ (scheme-file-suffix))))
+@end example
+
+or use @code{(provided? '@i{foo})} instead of @code{(defined?
+twiddle-bits!)} if you have added the feature.
+@item
+put documentation of the new procedures into @file{@i{foo}.doc}
+@item
+add lines to your @file{Makefile} to compile and link SCM with your
+object file. Add a @code{init_@i{foo}\(\)\;} to the @code{INITS=@dots{}}
+line at the beginning of the makefile.
+@end enumerate
+
+@noindent
+These steps should allow your package to be linked into SCM with a
+minimum of difficulty. Your package should also work with dynamic
+linking if your SCM has this capability.
+
+Special forms (new syntax) can be added to scm.
+
+@enumerate
+@item
+define a new @code{MAKISYM} in @file{scm.h} and increment
+@code{NUM_ISYMS}.
+@item
+add a string with the new name in the corresponding place in
+@code{isymnames} in @file{repl.c}.
+@item
+add @code{case:} clause to @code{ceval()} near @code{i_quasiquote} (in
+@file{eval.c}).
+@end enumerate
+
+@noindent
+New syntax can now be added without recompiling SCM by the use of the
+@code{procedure->syntax}, @code{procedure->macro},
+@code{procedure->memoizing-macro}, and @code{defmacro}. For details,
+@xref{Syntax Extensions}.
+
+@node Defining Subrs, Defining Smobs, Changing Scm, Operations
+@subsection Defining Subrs
+
+@noindent
+If @dfn{CCLO} is @code{#define}d when compiling, the compiled closure
+feature will be enabled. It is automatically enabled if dynamic linking
+is enabled.
+
+@noindent
+The SCM interpreter directly recognizes subrs taking small numbers of
+arguments. In order to create subrs taking larger numbers of arguments
+use:
+
+@defun make_gsubr name req opt rest fcn
+returns a cclo (compiled closure) object of name @code{char *}
+@var{name} which takes @code{int} @var{req} required arguments,
+@code{int} @var{opt} optional arguments, and a list of rest arguments if
+@code{int} @var{rest} is 1 (0 for not).
+
+@code{SCM (*fcn)()} is a pointer to a C function to do the work.
+
+The C function will always be called with @var{req} + @var{opt} +
+@var{rest} arguments, optional arguments not supplied will be passed
+@code{UNDEFINED}. An error will be signaled if the subr is called with
+too many or too few arguments. Currently a total of 10 arguments may be
+specified, but increasing this limit should not be difficult.
+
+@example
+/* A silly example, taking 2 required args,
+ 1 optional, and a list of rest args */
+
+#include <scm.h>
+
+SCM gsubr_21l(req1,req2,opt,rst)
+ SCM req1,req2,opt,rst;
+@{
+ lputs("gsubr-2-1-l:\n req1: ", cur_outp);
+ display(req1,cur_outp);
+ lputs("\n req2: ", cur_outp);
+ display(req2,cur_outp);
+ lputs("\n opt: ", cur_outp);
+ display(opt,cur_outp);
+ lputs("\n rest: ", cur_outp);
+ display(rst,cur_outp);
+ newline(cur_outp);
+ return UNSPECIFIED;
+@}
+
+void init_gsubr211()
+@{
+ make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l);
+@}
+@end example
+@end defun
+
+@node Defining Smobs, Defining Ptobs, Defining Subrs, Operations
+@subsection Defining Smobs
+
+@noindent
+Here is an example of how to add a new type named @code{@i{foo}} to SCM.
+The following lines need to be added to your code:
+
+@table @code
+@item long tc16_@i{foo};
+The type code which will be used to identify the new type.
+@item static smobfuns @i{foo}smob = @{mark@i{foo},free@i{foo},print@i{foo},equalp@i{foo}@};
+smobfuns is a structure composed of 4 functions:
+
+@example
+typedef struct @{
+ SCM (*mark)P((SCM));
+ sizet (*free)P((CELLPTR));
+ int (*print)P((SCM exp, SCM port, int writing));
+ SCM (*equalp)P((SCM, SCM));
+@} smobfuns;
+@end example
+
+@table @code
+@item smob.mark
+is a function of one argument of type @code{SCM} (the cell to mark) and
+returns type @code{SCM} which will then be marked. If no further
+objects need to be marked then return an immediate object such as
+@code{BOOL_F}. 2 functions are provided:
+
+@table @code
+@item markcdr(ptr)
+which marks the current cell and returns @code{CDR(ptr)}.
+@item mark0(ptr)
+which marks the current cell and returns @code{BOOL_F}.
+@end table
+
+@item smob.free
+is a function of one argument of type @code{CELLPTR} (the cell to
+collected) and returns type @code{sizet} which is the number of
+@code{malloc}ed bytes which were freed. @code{Smob.free} should free
+any @code{malloc}ed storage associated with this object. The function
+free0(ptr) is provided which does not free any storage and returns 0.
+@item smob.print
+is 0 or a function of 3 arguments. The first, of type @code{SCM}, is
+the smob object. The second, of type @code{SCM}, is the stream on which
+to write the result. The third, of type int, is 1 if the object should
+be @code{write}n, 0 if it should be @code{display}ed. This function
+should return non-zero if it printed, and zero otherwise (in which case
+a hexadecimal number will be printed).
+@item smob.equalp
+is 0 or a function of 2 @code{SCM} arguments. Both of these arguments
+will be of type @code{tc16@i{foo}}. This function should return
+@code{BOOL_T} if the smobs are equal, @code{BOOL_F} if they are not. If
+@code{smob.equalp} is 0, @code{equal?} will return @code{BOOL_F} if they
+are not @code{eq?}.
+@end table
+
+@item tc16_@i{foo} = newsmob(&@i{foo}smob);
+Allocates the new type with the functions from @code{@i{foo}smob}. This
+line goes in an @code{init_} routine.
+@end table
+
+@noindent
+Promises and macros in @file{eval.c} and arbiters in @file{repl.c}
+provide examples of SMOBs. There are a maximum of 256 SMOBs.
+
+@node Defining Ptobs, Calling Scheme From C, Defining Smobs, Operations
+@subsection Defining Ptobs
+
+@noindent
+@dfn{ptob}s are similar to smobs but define new types of port to which
+SCM procedures can read or write. The following functions are defined
+in the @code{ptobfuns}:
+
+@example
+typedef struct @{
+ SCM (*mark)P((SCM ptr));
+ int (*free)P((FILE *p));
+ int (*print)P((SCM exp, SCM port, int writing));
+ SCM (*equalp)P((SCM, SCM));
+ int (*fputc)P((int c, FILE *p));
+ int (*fputs)P((char *s, FILE *p));
+ sizet (*fwrite)P((char *s, sizet siz, sizet num, FILE *p));
+ int (*fflush)P((FILE *stream));
+ int (*fgetc)P((FILE *p));
+ int (*fclose)P((FILE *p));
+@} ptobfuns;
+@end example
+
+@noindent
+The @code{.free} component to the structure takes a @code{FILE *} or
+other C construct as its argument, unlike @code{.free} in a smob, which
+takes the whole smob cell. Often, @code{.free} and @code{.fclose} can be
+the same function. See @code{fptob} and @code{pipob} in @file{sys.c}
+for examples of how to define ptobs.
+
+@node Calling Scheme From C, Callbacks, Defining Ptobs, Operations
+@subsection Calling Scheme From C
+
+@noindent
+To use SCM as a whole from another program call @code{init_scm} or
+@code{run_scm} as is done in @code{main()} in @file{scm.c}.
+
+@noindent
+In order to call indivdual Scheme procedures from C code more is
+required; SCM's storage system needs to be initialized. The simplest
+way to do this for a statically linked single-thread program is to:
+
+@enumerate
+@item
+make a SCM procedure which calls your code's startup routine.
+@item
+use the @code{#define RTL} flag when compiling @file{scm.c} to elide
+SCM's @code{main()}.
+@item
+In your @code{main()}, call @code{run_scm} with arguments (@code{argc}
+and @code{argv}) to invoke your code's startup routine.
+@item
+link your code with SCM at compile time.
+@end enumerate
+
+@noindent
+For a dynamically linked single-thread program:
+
+@enumerate
+@item
+make an @code{init_} procedure for your code which will set up any Scheme
+definitions you need and then call your startup routine
+(@pxref{Changing Scm}).
+@item
+Start SCM with command line arguments to dynamically link your code.
+After your module is linked, the @code{init_} procedure will be called, and
+hence your startup routine.
+@end enumerate
+
+@noindent
+Now use @code{apply} (and perhaps @code{intern}) to call Scheme
+procedures from your C code. For example:
+
+@example
+/* If this apply fails, SCM will catch the error */
+apply(CDR(intern("srv:startup",sizeof("srv:startup")-1)),
+ mksproc(srvproc),
+ listofnull);
+
+func = CDR(intern(rpcname,strlen(rpcname)));
+retval = apply(func, cons(mksproc(srvproc), args), EOL);
+@end example
+
+@node Callbacks, Type Conversions, Calling Scheme From C, Operations
+@subsection Callbacks
+
+@noindent
+SCM now has routines to make calling back to Scheme procedures easier.
+The source code for these routines are found in @file{rope.c}.
+
+@deftypefun int scm_ldfile (char *@var{file})
+Loads the Scheme source file @var{file}. Returns 0 if successful, non-0
+if not. This function is used to load SCM's initialization file
+@file{Init.scm}.
+@end deftypefun
+
+@deftypefun int scm_ldprog (char *@var{file})
+Loads the Scheme source file @code{(in-vicinity (program-vicinity)
+@var{file})}. Returns 0 if successful, non-0 if not.
+
+This function is useful for compiled code init_ functions to load
+non-compiled Scheme (source) files. @code{program-vicinity} is the
+directory from which the calling code was loaded (@pxref{Vicinity, , ,
+slib, SLIB}).
+@end deftypefun
+
+@deftypefun SCM scm_evstr (char *@var{str})
+Returns the result of reading an expression from @var{str} and
+evaluating it.
+@end deftypefun
+
+@deftypefun void scm_ldstr (char *@var{str})
+Reads and evaluates all the expressions from @var{str}.
+@end deftypefun
+
+@noindent
+If you wish to catch errors during execution of Scheme code, then you
+can use a wrapper like this for your Scheme procedures:
+
+@example
+(define (srv:protect proc)
+ (lambda args
+ (define result #f) ; put default value here
+ (call-with-current-continuation
+ (lambda (cont)
+ (dynamic-wind (lambda () #t)
+ (lambda ()
+ (set! result (apply proc args))
+ (set! cont #f))
+ (lambda ()
+ (if cont (cont #f))))))
+ result))
+@end example
+
+@noindent
+Calls to procedures so wrapped will return even if an error occurs.
+
+@node Type Conversions, Continuations, Callbacks, Operations
+@subsection Type Conversions
+
+These type conversion functions are very useful for connecting SCM and C
+code. Most are defined in @file{rope.c}.
+
+@deftypefun SCM long2num (long @var{n})
+@deftypefunx SCM ulong2num (unsigned long @var{n})
+Return an object of type @code{SCM} corresponding to the @code{long} or
+@code{unsigned long} argument @var{n}. If @var{n} cannot be converted,
+@code{BOOL_F} is returned. Which numbers can be converted depends on
+whether SCM was compiled with the @code{BIGDIG} or @code{FLOATS} flags.
+
+To convert integer numbers of smaller types (@code{short} or
+@code{char}), use the macro @code{MAKINUM(n)}.
+@end deftypefun
+
+@deftypefun long num2long (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+@deftypefunx unsigned long num2ulong (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+@deftypefunx unsigned short num2ushort (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+@deftypefunx unsigned char num2uchar (SCM @var{num}, char *@var{pos}, char *@var{s_caller})
+These functions are used to check and convert @code{SCM} arguments to
+the named C type. The first argument @var{num} is checked to see it it
+is within the range of the destination type. If so, the converted
+number is returned. If not, the @code{ASSERT} macro calls @code{wta}
+with @var{num} and strings @var{pos} and @var{s_caller}. For a listing
+of useful predefined @var{pos} macros, @xref{C Macros}.
+
+@emph{Note:} Inexact numbers are accepted only by @code{num2long} and
+@code{num2ulong} (for when @code{SCM} is compiled without bignums). To
+convert inexact numbers to exact numbers, @xref{Numerical operations,
+inexact->exact, , r4rs, Revised(4) Scheme}.
+@end deftypefun
+
+@deftypefun unsigned long scm_addr (SCM @var{args}, char *@var{s_name})
+Returns a pointer (cast to an @code{unsigned long}) to the storage
+corresponding to the location accessed by
+@code{aref(CAR(args),CDR(args))}. The string @var{s_name} is used in
+any messages from error calls by @code{scm_addr}.
+
+@code{scm_addr} is useful for performing C operations on strings or
+other uniform arrays (@pxref{Uniform Array}).
+
+@emph{Note:} While you use a pointer returned from @code{scm_addr} you
+must keep a pointer to the associated @code{SCM} object in a stack
+allocated variable or GC-protected location in order to assure that SCM
+does not reuse that storage before you are done with it.
+@end deftypefun
+
+@deftypefun SCM makfrom0str (char *@var{src})
+@deftypefunx SCM makfromstr (char *@var{src}, sizet @var{len})
+Return a newly allocated string @code{SCM} object copy of the
+null-terminated string @var{src} or the string @var{src} of length
+@var{len}, respectively.
+@end deftypefun
+
+@deftypefun SCM makfromstrs (int @var{argc}, char **@var{argv})
+Returns a newly allocated @code{SCM} list of strings corresponding to
+the @var{argc} length array of null-terminated strings @var{argv}. If
+@var{argv} is less than @code{0}, @var{argv} is assumed to be
+@code{NULL} terminated. @code{makfromstrs} is used by @code{run_scm} to
+convert the arguments SCM was called with to a @code{SCM} list which is
+the value of SCM procedure calls to @code{program-arguments}
+(@pxref{System Interface, program-arguments}).
+@end deftypefun
+
+@deftypefun char **makargvfrmstrs (SCM @var{args}, char *@var{s_name})
+Returns a @code{NULL} terminated list of null-terminated strings copied
+from the @code{SCM} list of strings @var{args}. The string @var{s_name}
+is used in messages from error calls by @code{makargvfrmstrs}.
+
+@code{makargvfrmstrs} is useful for constructing argument lists suitable
+for passing to @code{main} functions.
+@end deftypefun
+
+@deftypefun void must_free_argv (char **@var{argv})
+Frees the storage allocated to create @var{argv} by a call to
+@code{makargvfrmstrs}.
+@end deftypefun
+
+@node Continuations, Evaluation, Type Conversions, Operations
+@subsection Continuations
+
+@noindent
+The source files @file{continue.h} and @file{continue.c} are designed to
+function as an independent resource for programs wishing to use
+continuations, but without all the rest of the SCM machinery. The
+concept of continuations is explained in @ref{Control features,
+call-with-current-continuation, , r4rs, Revised(4) Scheme}.
+
+@deftp {Data type} CONTINUATION jmpbuf length stkbse other parent
+is a @code{typedef}ed structure holding all the information needed to
+represent a continuation. The @var{other} slot can be used to hold any
+data the user wishes to put there by defining the macro
+@code{CONTINUATION_OTHER}.
+@end deftp
+
+@defmac SHORT_ALIGN
+If @code{SHORT_ALIGN} is @code{#define}d (in @file{scmfig.h}), then the
+it is assumed that pointers in the stack can be aligned on @code{short
+int} boundaries.
+@end defmac
+
+@deftp {Data type} STACKITEM
+is a pointer to objects of the size specified by @code{SHORT_ALIGN}
+being @code{#define}d or not.
+@end deftp
+
+@defmac CHEAP_CONTINUATIONS
+If @code{CHEAP_CONTINUATIONS} is @code{#define}d (in @file{scmfig.h})
+each @code{CONTINUATION} has size @code{sizeof CONTINUATION}.
+Otherwise, all but @dfn{root} @code{CONTINUATION}s have additional
+storage (immediately following) to contain a copy of part of the stack.
+
+@emph{Note:} On systems with nonlinear stack disciplines (multiple
+stacks or non-contiguous stack frames) copying the stack will not work
+properly. These systems need to #define @code{CHEAP_CONTINUATIONS} in
+@file{scmfig.h}.
+@end defmac
+
+@defmac STACK_GROWS_UP
+Expresses which way the stack grows by its being @code{#define}d or not.
+@end defmac
+
+@deftypevar long thrown_value
+Gets set to the @var{value} passed to @code{throw_to_continuation}.
+@end deftypevar
+
+@deftypefun long stack_size (STACKITEM *@var{start})
+Returns the number of units of size @code{STACKITEM} which fit between
+@var{start} and the current top of stack. No check is done in this
+routine to ensure that @var{start} is actually in the current stack
+segment.
+@end deftypefun
+
+@deftypefun CONTINUATION *make_root_continuation (STACKITEM *@var{stack_base})
+Allocates (@code{malloc}) storage for a @code{CONTINUATION} of the
+current extent of stack. This newly allocated @code{CONTINUATION} is
+returned if successful, @code{0} if not. After
+@code{make_root_continuation} returns, the calling routine still needs
+to @code{setjmp(@var{new_continuation}->jmpbuf)} in order to complete
+the capture of this continuation.
+@end deftypefun
+
+@deftypefun CONTINUATION *make_continuation (CONTINUATION *@var{parent_cont})
+Allocates storage for the current @code{CONTINUATION}, copying (or
+encapsulating) the stack state from @code{@var{parent_cont}->stkbse} to
+the current top of stack. The newly allocated @code{CONTINUATION} is
+returned if successful, @code{0}q if not. After
+@code{make_continuation} returns, the calling routine still needs to
+@code{setjmp(@var{new_continuation}->jmpbuf)} in order to complete the
+capture of this continuation.
+@end deftypefun
+
+@deftypefun void free_continuation (CONTINUATION *@var{cont})
+Frees the storage pointed to by @var{cont}. Remember to free storage
+pointed to by @code{@var{cont}->other}.
+@end deftypefun
+
+@deftypefun void throw_to_continuation (CONTINUATION *@var{cont}, long @var{value}, CONTINUATION *@var{root_cont})
+Sets @code{thrown_value} to @var{value} and returns from the
+continuation @var{cont}.
+
+If @code{CHEAP_CONTINUATIONS} is @code{#define}d, then
+@code{throw_to_continuation} does @code{longjmp(@var{cont}->jmpbuf, val)}.
+
+If @code{CHEAP_CONTINUATIONS} is not @code{#define}d, the CONTINUATION
+@var{cont} contains a copy of a portion of the C stack (whose bound must
+be @code{CONT(@var{root_cont})->stkbse}). Then:
+
+@itemize @bullet
+@item
+the stack is grown larger than the saved stack, if neccessary.
+@item
+the saved stack is copied back into it's original position.
+@item
+@code{longjmp(@var{cont}->jmpbuf, val)};
+@end itemize
+@end deftypefun
+
+@node Evaluation, , Continuations, Operations
+@subsection Evaluation
+
+SCM uses its type representations to speed evaluation. All of the
+@code{subr} types (@pxref{Subr Cells}) are @code{tc7} types. Since the
+@code{tc7} field is in the low order bit position of the @code{CAR} it
+can be retrieved and dispatched on quickly by dereferencing the SCM
+pointer pointing to it and masking the result.
+
+All the SCM @dfn{Special Forms} get translated to immediate symbols
+(@code{isym}) the first time they are encountered by the interpreter
+(@code{ceval}). The representation of these immediate symbols is
+engineered to occupy the same bits as @code{tc7}. All the @code{isym}s
+occur only in the @code{CAR} of lists.
+
+If the @code{CAR} of a expression to evaluate is not immediate, then it
+may be a symbol. If so, the first time it is encountered it will be
+converted to an immediate type @code{ILOC} or @code{GLOC}
+(@pxref{Immediates}). The codes for @code{ILOC} and @code{GLOC} lower 7
+bits distinguish them from all the other types we have discussed.
+
+Once it has determined that the expression to evaluate is not immediate,
+@code{ceval} need only retrieve and dispatch on the low order 7 bits of
+the @code{CAR} of that cell, regardless of whether that cell is a
+closure, header, or subr, or a cons containing @code{ILOC} or
+@code{GLOC}.
+
+In order to be able to convert a SCM symbol pointer to an immediate @code{ILOC}
+or @code{GLOC}, the evaluator must be holding the pointer to the list in which
+that symbol pointer occurs. Turning this requirement to an advantage,
+@code{ceval} does not recursively call itself to evaluate symbols in
+lists; It instead calls the macro @dfn{EVALCAR}. @code{EVALCAR} does
+symbol lookup and memoization for symbols, retrieval of values for @code{ILOC}s
+and @code{GLOC}s, returns other immediates, and otherwise recursively calls
+itself with the @code{CAR} of the list.
+
+@code{ceval} inlines evaluation (using @code{EVALCAR}) of almost all
+procedure call arguments. When @code{ceval} needs to evaluate a list of
+more than length 3, the procedure @code{eval_args} is called. So
+@code{ceval} can be said to have one level lookahead. The avoidance of
+recursive invocations of @code{ceval} for the most common cases (special
+forms and procedure calls) results in faster execution. The speed of
+the interpreter is currently limited on most machines by interpreter
+size, probably having to do with its cache footprint. In order to keep
+the size down, certain @code{EVALCAR} calls which don't need to be fast
+(because they rarely occur or because they are part of expensive
+operations) are instead calls to the C function @code{evalcar}.
+
+There was some discussion a year ago about a "Forth" style Scheme
+interpreter. This is the only improvement I know of which would beat
+SCM in speed.
+
+@quotation
+Provided there is still type code space available in SCM, if we devote
+some of the IMCAR codes to "inlined" operations, we should get a
+significant performance boost. What is eliminated is the having to look
+up a @code{GLOC} or @code{ILOC} and then dispatch on the subr type. The
+IMCAR operation would be dispatched to directly. Another way to view
+this is that we make available special form versions of @code{CAR},
+@code{CDR}, etc. Since the actual operation code is localized in the
+interpreter, it is much easier than uncompilation and then recompilation
+to handle @code{(trace car)}; For instance a switch gets set which tells
+the interpreter to instead always look up the values of the associated
+symbols.
+@end quotation
+
+@defvar symhash
+Top level symbol values are stored in the @code{symhash} table.
+@code{symhash} is an array of lists of @code{ISYM}s and pairs of symbols
+and values.
+@end defvar
+
+@deftp Immediate ILOC
+Whenever a symbol's value is found in the local environment the pointer
+to the symbol in the code is replaced with an immediate object
+(@code{ILOC}) which specifies how many environment frames down and how
+far in to go for the value. When this immediate object is subsequently
+encountered, the value can be retrieved quickly.
+@end deftp
+
+@deftp Immediate GLOC
+Pointers to symbols not defined in local environments are changed to one
+plus the value cell address in symhash. This incremented pointer is
+called a @code{GLOC}. The low order bit is normally reserved for
+GCmark; But, since references to variables in the code always occur in
+the @code{CAR} position and the GCmark is in the @code{CDR}, there is no
+conflict.
+@end deftp
+
+If the compile FLAG @code{CAUTIOUS} is #defined then the number of
+arguments is always checked for application of closures. If the compile
+FLAG @code{RECKLESS} is #defined then they are not checked. Otherwise,
+number of argument checks for closures are made only when the function
+position (whose value is the closure) of a combination is not an
+@code{ILOC} or @code{GLOC}. When the function position of a combination
+is a symbol it will be checked only the first time it is evaluated
+because it will then be replaced with an @code{ILOC} or @code{GLOC}.
+
+@defmac EVAL expression env
+@defmacx SIDEVAL expression env
+@code{EVAL} Returns the result of evaluating @var{expression} in
+@var{env}. @code{SIDEVAL} evaluates @var{expression} in @var{env} when
+the value of the expression is not used.
+
+Both of these macros alter the list structure of @var{expression} as it
+is memoized and hence should be used only when it is known that
+@var{expression} will not be referenced again. The C function
+@code{eval} is safe from this problem.
+@end defmac
+
+@deftypefun SCM eval (SCM @var{expression})
+Returns the result of evaluating @var{expression} in the top-level
+environment. @code{eval} copies @code{expression} so that memoization
+does not modify @code{expression}.
+@end deftypefun
+
+@node Improvements To Make, Finishing Dynamic Linking, Operations, The Implementation
+@section Improvements To Make
+
+@itemize @bullet
+@item
+Prefix and make more uniform all C function, variable, and constant
+names. Provide a file full of #define's to provide backward
+compatability.
+@item
+@code{lgcd()} @emph{needs} to generate at most one bignum, but currently
+generates more.
+@item
+@code{divide()} could use shifts instead of multiply and divide when
+scaling.
+@item
+If an open fails because there are no unused file handles, GC should
+be done so that file handles which are no longer used can be
+collected.
+@item
+Currently, @code{dump}ing an executable does not preserve ports. When
+loading a @code{dump}ed executable, disk files could be reopened to the
+same file and position as they had when the executable was dumped.
+@item
+Compaction could be done to @code{malloc}ed objects by freeing and
+reallocing all the malloc objects encountered in a scan of the heap.
+Whether compactions would actually occur is system depenedent.
+@item
+Copying all of the stack is wasteful of storage. Any time a
+call-with-current-continuation is called the stack could be re-rooted
+with a frame which calls the contin just created. This in combination
+with checking stack depth could also be used to allow stacks deeper
+than 64K on the IBM PC.
+@item
+lookupcar in @file{eval.c} should @emph{not} memoize (to @code{ILOC}s)
+when it retrieves environments deeper or longer than 4095. The values
+can still be retrieved (albeit slowly), but an @code{ILOC} should not be
+made. The @code{MEMOIZE_LOCALS} flag could then be flushed.
+@item
+The @code{must-} or @code{make-} routines need some sort of C macros or
+conditionalization so that they check:
+
+@itemize @bullet
+@item
+that the @code{LENGTH} field fits into a @code{size_t} (as is checked
+now) for platforms with @code{(sizeof(size_t) < sizeof(SCM))}.
+@item
+that the @code{LENGTH} field fits into 24 (or 56) bits on machines where
+@code{size_t} is 32 bits or more.
+@end itemize
+
+This is trickier than it first looks because the must_malloc() routine
+is also used for allocating heap segments, which do not have the
+@code{LENGTH} field restriction. Putting the 24 bit test into
+@code{must_malloc()} should be tested for speed impact.
+@end itemize
+
+@node Finishing Dynamic Linking, , Improvements To Make, The Implementation
+@section Finishing Dynamic Linking
+
+@noindent
+Scott Schwartz <schwartz@@galapagos.cse.psu.edu> suggests: One way to
+tidy up the dynamic loading stuff would be to grab the code from perl5.
+
+@subsubheading VMS
+
+@noindent
+George Carrette (gjc@@mitech.com) outlines how to dynamically link on
+VMS. There is already some code in @file{dynl.c} to do this, but
+someone with a VMS system needs to finish and debug it.
+
+@enumerate
+@item
+Say you have this @file{main.c} program:
+
+@format
+@t{main()
+@{init_lisp();
+ lisp_repl();@}}
+@end format
+
+@item
+and you have your lisp in files @file{repl.c}, @file{gc.c},
+@code{eval.c} and there are some toplevel non-static variables in use
+called @code{the_heap}, @code{the_environment}, and some read-only
+toplevel structures, such as @code{the_subr_table}.
+
+@format
+@t{$ LINK/SHARE=LISPRTL.EXE/DEBUG REPL.OBJ,GC.OBJ,EVAL.OBJ,LISPRTL.OPT/OPT}
+@end format
+
+@item
+where @file{LISPRTL.OPT} must contain at least this:
+
+@format
+@t{SYS$LIBRARY:VAXCRTL/SHARE
+UNIVERSAL=init_lisp
+UNIVERSAL=lisp_repl
+PSECT_ATTR=the_subr_table,SHR,NOWRT,LCL
+PSECT_ATTR=the_heap,NOSHR,LCL
+PSECT_ATTR=the_environment,NOSHR,LCL}
+@end format
+
+@emph{Notice:} The @dfn{psect} (Program Section) attributes.
+@table @code
+@item LCL
+means to keep the name local to the shared library. You almost always
+want to do that for a good clean library.
+@item SHR,NOWRT
+means shared-read-only. Which is the default for code, and is also good
+for efficiency of some data structures.
+@item NOSHR,LCL
+is what you want for everything else.
+@end table
+
+Note: If you do not have a handy list of all these toplevel variables,
+do not dispair. Just do your link with the /MAP=LISPRTL.MAP/FULL
+and then search the map file,
+
+@format
+@t{$SEARCH/OUT=LISPRTL.LOSERS LISPRTL.MAP ", SHR,NOEXE, RD, WRT"}
+@end format
+
+And use an emacs keyboard macro to muck the result into the proper form.
+Of course only the programmer can tell if things can be made read-only.
+I have a DCL command procedure to do this if you want it.
+
+@item
+@noindent
+Now MAIN.EXE would be linked thusly:
+
+@format
+@t{$ DEFINE LISPRTL USER$DISK:[JAFFER]LISPRTL.EXE
+
+$LINK MAIN.OBJ,SYS$INPUT:/OPT
+ SYS$LIBRARY:VAXCRTL/SHARE
+ LISPRTL/SHARE}
+@end format
+
+Note the definition of the @code{LISPRTL} logical name. Without such a
+definition you will need to copy @file{LISPRTL.EXE} over to
+@file{SYS$SHARE:} (aka @file{SYS$LIBRARY:}) in order to invoke the main
+program once it is linked.
+
+@item
+Now say you have a file of optional subrs, @file{MYSUBRS.C}. And there
+is a routine @code{INIT_MYSUBRS} that must be called before using it.
+
+@format
+@t{$ CC MYSUBRS.C
+$ LINK/SHARE=MYSUBRS.EXE MYSUBRS.OBJ,SYS$INPUT:/OPT
+ SYS$LIBRARY:VAXCRTL/SHARE
+ LISPRTL/SHARE
+ UNIVERSAL=INIT_MYSUBRS}
+@end format
+
+Ok. Another hint is that you can avoid having to add the @code{PSECT}
+declaration of @code{NOSHR,LCL} by declaring variables @code{status} in
+the C language source. That works great for most things.
+
+@item
+Then the dynamic loader would have to do this:
+
+@format
+@t{@{void (*init_fcn)();
+ long retval;
+ retval = lib$find_image_symbol("MYSUBRS","INIT_MYSUBRS",&init_fcn,
+ "SYS$DISK:[].EXE");
+ if (retval != SS$_NORMAL) error(@dots{});
+ (*init_fcn)();@}}
+@end format
+
+But of course all string arguments must be @code{(struct dsc$descriptor
+*)} and the last argument is optional if @code{MYSUBRS} is defined as a
+logical name or if @file{MYSUBRS.EXE} has been copied over to
+@file{SYS$SHARE}. The other consideration is that you will want to turn
+off @key{C-c} or other interrupt handling while you are inside most
+@code{lib$} calls.
+
+As far as the generation of all the @code{UNIVERSAL=@dots{}}
+declarations. Well, you could do well to have that automatically
+generated from the public @file{LISPRTL.H} file, of course.
+
+VMS has a good manual called the @cite{Guide to Writing Modular
+Procedures} or something like that, which covers this whole area rather
+well, and also talks about advanced techniques, such as a way to declare
+a program section with a pointer to a procedure that will be
+automatically invoked whenever any shared image is dynamically
+activated. Also, how to set up a handler for normal or abnormal program
+exit so that you can clean up side effects (such as opening a database).
+But for use with @code{LISPRTL} you probably don't need that hair.
+
+One fancier option that is useful under VMS for @file{LISPLIB.EXE} is to
+define all your exported procedures through an @dfn{call vector} instead
+of having them just be pointers into random places in the image, which
+is what you get by using @code{UNIVERSAL}.
+
+If you set up the call vector thing correctly it will allow you to
+modify and relink @file{LISPLIB.EXE} without having to relink programs
+that have been linked against it.
+@end enumerate
+
+@subsubheading Windows NT
+@noindent
+George Carrette (gjc@@mitech.com) outlines how to dynamically link on
+Windows NT:
+
+@itemize @bullet
+@item
+The Software Developers Kit has a sample called SIMPLDLL.
+Here is the gist of it, following along the lines of the VMS description
+above (contents of a makefile for the SDK NMAKE)
+
+@format
+@t{LISPLIB.exp:
+LISPLIB.lib: LISPLIB.def
+ $(implib) -machine:$(CPU) -def:LISPLIB.def -out:LISPLIB.lib
+
+LISPLIB.DLL : $(LISPLIB_OBJS) LISPLIB.EXP
+ $(link) $(linkdebug) \
+ -dll \
+ -out:LISPLIB.DLL \
+ LISPLIB.EXP $(LISPLIB_OBJS) $(conlibsdll)}
+@end format
+
+@item
+The @file{LISPDEF.DEF} file has this:
+
+@format
+@t{LIBRARY lisplib
+EXPORT
+ init_lisp
+ init_repl}
+@end format
+
+@item
+And @file{MAIN.EXE} using:
+
+@format
+@t{CLINK = $(link) $(ldebug) $(conflags) -out:$*.exe $** $(conlibsdll)
+
+MAIN.EXE : MAIN.OBJ LISPLIB.LIB
+ $(CLINK)}
+@end format
+
+@item
+And @file{MYSUBRS.DLL} is produced using:
+
+@format
+@t{mysubrs.exp:
+mysubrs.lib: mysubrs.def
+ $(implib) -machine:$(CPU) -def:MYSUBRS.def -out:MYSUBRS.lib
+
+mysubrs.dll : mysubrs.obj mysubrs.exp mysubrs.lib
+ $(link) $(linkdebug) \
+ -dll \
+ -out:mysubrs.dll \
+ MYSUBRS.OBJ MYSUBRS.EXP LISPLIB.LIB $(conlibsdll)}
+@end format
+
+@item
+Where @file{MYSUBRS.DEF} has
+
+@format
+@t{LIBRARY mysubrs
+EXPORT
+ INIT_MYSUBRS}
+@end format
+
+@item
+And the dynamic loader looks something like this, calling the two
+procedures @code{LoadLibrary} and @code{GetProcAddress}.
+
+@format
+@t{LISP share_image_load(LISP fname)
+@{long iflag;
+ LISP retval,(*fcn)(void);
+ HANDLE hLib;
+ DWORD err;
+ char *libname,fcnname[64];
+ iflag = nointerrupt(1);
+ libname = c_string(fname);
+ _snprintf(fcnname,sizeof(fcnname),"INIT_%s",libname);
+ if (!(hLib = LoadLibrary(libname)))
+ @{err = GetLastError();
+ retval = list2(fname,LSPNUM(err));
+ serror1("library failed to load",retval);@}
+ if (!(fcn = (LISP (*)(void)) GetProcAddress(hLib,fcnname)))
+ @{err = GetLastError();
+ retval = list2(fname,LSPNUM(err));
+ serror1("could not find library init procedure",retval);@}
+ retval = (*fcn)();
+ nointerrupt(iflag);
+ return(retval);@}}
+@end format
+
+@item
+@emph{Note:} in VMS the linker and dynamic loader is case sensitive, but
+all the language compilers, including C, will by default upper-case
+external symbols for use by the linker, although the debugger gets its
+own symbols and case sensitivity is language mode dependant. In Windows
+NT things are case sensitive generally except for file and device names,
+which are case canonicalizing like in the Symbolics filesystem.
+
+@item
+@emph{Also:} All this WINDOWS NT stuff will work in MS-DOS MS-Windows
+3.1 too, by a method of compiling and linking under Windows NT, and then
+copying various files over to MS-DOS/WINDOWS.
+@end itemize
+
+
+@node Procedure and Macro Index, Variable Index, The Implementation, Top
+@unnumbered Procedure and Macro Index
+
+This is an alphabetical list of all the procedures and macros in SCM.
+
+@printindex fn
+
+@node Variable Index, Type Index, Procedure and Macro Index, Top
+@unnumbered Variable Index
+
+This is an alphabetical list of all the global variables in SCM.
+
+@printindex vr
+
+@node Type Index, , Variable Index, Top
+@unnumbered Type Index
+
+This is an alphabetical list of all the data types in SCM.
+
+@printindex tp
+
+@contents
+@bye
diff --git a/scm4e3.scmconfig.patch b/scm4e3.scmconfig.patch
new file mode 100644
index 0000000..ff7dc48
--- /dev/null
+++ b/scm4e3.scmconfig.patch
@@ -0,0 +1,60 @@
+diff -c temp/scm/findexec.c temp/nscm/findexec.c
+*** temp/scm/findexec.c Sun Mar 17 23:16:26 1996
+--- temp/nscm/findexec.c Thu Mar 21 08:51:27 1996
+***************
+*** 37,46 ****
+ filename. A new copy of the complete path name of that file is
+ returned. This new string may be disposed by free() later on. */
+
+ #include <sys/file.h>
+ #include <sys/param.h>
+! #include <strings.h>
+! #ifdef linux
+ # include <stdlib.h>
+ # include <sys/stat.h>
+ # include <unistd.h> /* for X_OK define */
+--- 37,47 ----
+ filename. A new copy of the complete path name of that file is
+ returned. This new string may be disposed by free() later on. */
+
++ #include "scm.h"
++
+ #include <sys/file.h>
+ #include <sys/param.h>
+! #if defined(linux) || defined(__svr4__)
+ # include <stdlib.h>
+ # include <sys/stat.h>
+ # include <unistd.h> /* for X_OK define */
+***************
+*** 116,122 ****
+ if (*p) p++;
+
+ if (name[0] == '.' && name[1] == 0)
+! getwd(name);
+
+ else if (name[0]=='~' && name[1]==0 && getenv("HOME"))
+ strcpy(name, getenv("HOME"));
+--- 117,123 ----
+ if (*p) p++;
+
+ if (name[0] == '.' && name[1] == 0)
+! getcwd(name, MAXPATHLEN);
+
+ else if (name[0]=='~' && name[1]==0 && getenv("HOME"))
+ strcpy(name, getenv("HOME"));
+diff -c temp/scm/scmfig.h temp/nscm/scmfig.h
+*** temp/scm/scmfig.h Fri Sep 22 22:29:00 1995
+--- temp/nscm/scmfig.h Wed Mar 20 23:47:15 1996
+***************
+*** 50,55 ****
+--- 50,59 ----
+ # include <strings.h>
+ # endif
+
++ # ifndef HAVE_GETCWD
++ # define getcwd(S,L) getwd(S)
++ # endif
++
+ #else /* HAVE_CONFIG_H */
+
+ # ifdef sequent
diff --git a/scmconfig.h.in b/scmconfig.h.in
new file mode 100644
index 0000000..5fb6d27
--- /dev/null
+++ b/scmconfig.h.in
@@ -0,0 +1,69 @@
+/* scmconfig.h.in. Generated automatically from configure.in by autoheader. */
+
+/* Define if on AIX 3.
+ System headers sometimes define this.
+ We just want to avoid a redefinition error message. */
+#ifndef _ALL_SOURCE
+#undef _ALL_SOURCE
+#endif
+
+/* Define to empty if the keyword does not work. */
+#undef const
+
+/* Define if on MINIX. */
+#undef _MINIX
+
+/* Define if your C compiler doesn't accept -c and -o together. */
+#undef NO_MINUS_C_MINUS_O
+
+/* Define if the system does not provide POSIX.1 features except
+ with this defined. */
+#undef _POSIX_1_SOURCE
+
+/* Define if you need to in order for stat and other things to work. */
+#undef _POSIX_SOURCE
+
+/* Define as the return type of signal handlers (int or void). */
+#undef RETSIGTYPE
+
+/* Define if you have the ANSI C header files. */
+#undef STDC_HEADERS
+
+/* Define if you can safely include both <sys/time.h> and <time.h>. */
+#undef TIME_WITH_SYS_TIME
+
+/* Define if you have ftime. */
+#undef HAVE_FTIME
+
+/* Define if you have getcwd. */
+#undef HAVE_GETCWD
+
+/* Define if you have times. */
+#undef HAVE_TIMES
+
+/* Define if you have the <limits.h> header file. */
+#undef HAVE_LIMITS_H
+
+/* Define if you have the <memory.h> header file. */
+#undef HAVE_MEMORY_H
+
+/* Define if you have the <string.h> header file. */
+#undef HAVE_STRING_H
+
+/* Define if you have the <sys/time.h> header file. */
+#undef HAVE_SYS_TIME_H
+
+/* Define if you have the <sys/timeb.h> header file. */
+#undef HAVE_SYS_TIMEB_H
+
+/* Define if you have the <sys/times.h> header file. */
+#undef HAVE_SYS_TIMES_H
+
+/* Define if you have the <sys/types.h> header file. */
+#undef HAVE_SYS_TYPES_H
+
+/* Define if you have the <time.h> header file. */
+#undef HAVE_TIME_H
+
+/* Define if you have the <unistd.h> header file. */
+#undef HAVE_UNISTD_H
diff --git a/scmfig.h b/scmfig.h
new file mode 100644
index 0000000..ba95450
--- /dev/null
+++ b/scmfig.h
@@ -0,0 +1,671 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "scmfig.h" system-dependent configuration.
+ Author: Aubrey Jaffer */
+
+#ifdef HAVE_CONFIG_H
+# include "scmconfig.h"
+# ifdef HAVE_STRING_H
+# include <string.h>
+# else
+# include <strings.h>
+# endif
+
+# ifndef HAVE_GETCWD
+# define getcwd(S,L) getwd(S)
+# endif
+
+#else /* HAVE_CONFIG_H */
+
+# ifdef sequent
+# include <strings.h>
+# define strchr index
+# define strrchr rindex
+# else
+# include <string.h>
+# endif
+
+# include "scmflags.h" /* user specified, system independent flags */
+
+/* IMPLINIT is the full pathname (surrounded by double quotes) of
+ Init.scm, the Scheme initialization code. This is best defined in
+ the makefile, if possible. If available, scm uses the value of
+ environment variable SCM_INIT_PATH instead of IMPLINIT. */
+
+/* #define IMPLINIT "/usr/jaffer/scm/Init.scm" */
+
+/* INITS is calls to initialization routines for any compiled
+ libraries being linked into scm. This is best done in the makefile.
+File: INITS line: functions defined:
+
+sc2.c init_sc2(); substring-move-left!, substring-move-right!,
+ substring-fill!, append!, and last-pair
+rgx.c init_rgx(); regcomp and regexec. */
+
+/* #define INITS init_sc2(); */
+
+/* #define SICP */
+
+/* setbuf(0) needs to be done for tty ports in order for CHAR-READY?
+ to work. This can cause problems under MSDOS and other systems. */
+
+/* #define NOSETBUF */
+
+/* #define RECKLESS */
+
+/* #define CAUTIOUS */
+
+/* #define STACK_LIMIT (HEAP_SEG_SIZE/2) */
+
+/* #define BIGNUMS */
+
+/* #define ARRAYS */
+
+/* #define FLOATS */
+
+/* Define SINGLES if you want single precision floats and
+ (sizeof(float)==sizeof(long)) */
+
+# ifdef FLOATS
+# define SINGLES
+# endif
+
+/* #define SINGLESONLY */
+
+/* Define CDR_DOUBLES if (sizeof(double)==sizeof(long)), i.e.
+ a `single' is really a double. */
+# ifdef FLOATS
+# ifdef __alpha
+# define CDR_DOUBLES
+# endif
+
+# ifdef _UNICOS /* doubles are no better than singles on Cray. */
+# define SINGLESONLY
+# endif
+
+# ifdef CDR_DOUBLES
+# define SINGLES
+# define SINGLESONLY
+# endif
+# endif
+
+/* #define ENGNOT */
+
+/* Define SUN_DL to configure code in "dynl.c" so that dynamic linking
+ is done using the SUN dynamic linking library "dl". */
+
+/* #define SUN_DL */
+
+/* Define DLD to configure code in "dynl.c" so that dynamic linking is
+ done using the "dld" library. DLD is ported to Linux, VAX
+ (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation (SunOS 4.0),
+ Sequent Symmetry (Dynix), and Atari ST. See scm/README or
+ scm/ANNOUNCE for ftp sites offering dld. */
+
+/* #define DLD */
+
+/* Define HAVE_DYNL if dynamic linking is available */
+
+# ifdef DLD
+# define HAVE_DYNL
+# endif
+# ifdef SUN_DL
+# define HAVE_DYNL
+# endif
+# ifdef HP_SHL
+# define HAVE_DYNL
+# endif
+
+# ifdef HAVE_DYNL
+# define CCLO
+# endif
+
+/* Define GC_FREE_SEGMENTS if you want segments of unused heap to
+ be freed up after garbage collection. Don't define it if you
+ never want the heap to shrink. */
+
+# ifndef DONT_GC_FREE_SEGMENTS
+# define GC_FREE_SEGMENTS
+# endif
+
+/* MEMOIZE_LOCALS will speed up most local variable references. You
+ will need to remove this and recompile eval.c if you use very large or
+ deep environments (more than 4095 bound variables in one procedure)*/
+
+# define MEMOIZE_LOCALS
+
+/* #define CHEAP_CONTINUATIONS */
+
+/* #define TICKS */
+
+/* PROT386 should be defined on the compilation command line if the
+ program is to be run on an intel 386 in protected mode. `Huge'
+ pointers common on MSDOS compilers do not work in protected mode.
+ PROT386 is required if scm is to run as part of a Microsoft Windows
+ application. Added by Stephen Adams 8 May 92 */
+
+/* #define PROT386 */
+
+/* #define NON_PREEMPTIVE and RTL if you are using an non-preemptive
+ operating system in which periodic polling for interrupts is
+ necessary. Provide your own main procedure (e.g., WinMain, in
+ Windows). Define and initialize unsigned int poll_count, and
+ provide a procedure named poll_routine(), which POLL calls each
+ time poll_count reaches zero. poll_routine() must reinitialize
+ poll_count. It may also check for external actions, such as
+ Windows messages. The value assigned to poll_count can be quite
+ large, e.g., 1000, while still maintaining good response time. */
+
+/* #define CAREFUL_INTS */
+
+/* STDC_HEADERS indicates that the include file names are the same as
+ ANSI C. For most modern systems this is the case. */
+
+/* added by Yasuaki Honda */
+# ifdef THINK_C
+# define __STDC__
+# endif
+
+# ifdef __STDC__
+# ifndef __HIGHC__ /* overly fussy compiler */
+# define USE_ANSI_PROTOTYPES
+# endif
+# ifndef __GNUC__
+# define STDC_HEADERS
+# else
+# ifdef sparc
+# ifdef SVR4
+# define STDC_HEADERS
+# endif
+# else
+# ifndef tahoe
+# ifndef sun
+# define STDC_HEADERS
+# endif
+# endif
+# endif
+# endif
+# endif
+# ifdef MSDOS /* Microsoft C 5.10 and 6.00A */
+# ifndef GO32
+# define SHORT_INT
+# endif
+# endif
+# ifdef _QC
+# define SHORT_INT
+# endif
+# ifdef __TURBOC__
+# define SHORT_INT
+# ifndef __TOS__
+# define MSDOS
+# endif
+# endif
+# ifdef _WIN32
+# define MSDOS
+# define LACK_TIMES
+# endif
+# ifdef _MSDOS
+# define MSDOS
+# endif
+# ifdef MSDOS
+# define STDC_HEADERS
+# endif
+# ifdef vms
+# define STDC_HEADERS
+# endif
+# ifdef nosve
+# define STDC_HEADERS
+# endif
+
+# ifdef linux
+# define HAVE_SELECT
+# define HAVE_SYS_TIME_H
+# undef STDC_HEADERS
+# endif
+
+# ifdef _UNICOS
+# define STDC_HEADERS
+# endif
+
+# ifdef _AIX
+# define _POSIX_SOURCE
+# define LACK_FTIME
+# endif
+
+# ifdef __sgi__
+# define LACK_FTIME
+# define STDC_HEADERS
+# define USE_ANSI_PROTOTYPES
+# define HAVE_SELECT
+# define HAVE_SYS_TIME_H
+# define __svr4__
+# endif
+
+# ifdef hpux
+# define LACK_E_IDs
+# endif
+
+/* C-Set++ for OS/2 */
+# ifdef __IBMC__
+# define STDC_HEADERS
+# define LACK_TIMES
+# endif
+
+#endif /* HAVE_CONFIG_H */
+
+/* PROMPT is the prompt string printed at top level */
+
+#ifndef PROMPT
+# ifdef SICP
+# define PROMPT "==> "
+# else
+# define PROMPT "> "
+# endif
+#endif
+
+/* #define BRACKETS_AS_PARENS to have [ and ] be read as ( and ) in forms. */
+
+/* #define BRACKETS_AS_PARENS */
+
+/* LINE_INCREMENTORS are the characters which cause the line count to
+ be incremented for the purposes of error reporting. This feature
+ is only used for scheme code loaded from files.
+
+ WHITE_SPACES are other characters which should be treated like spaces
+ in programs. in both cases sparate characters with ":case " */
+
+#define LINE_INCREMENTORS '\n'
+#ifdef MSDOS
+# define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26
+#else
+# define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
+#endif
+
+/* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */
+
+#define NUM_HASH_BUCKETS 137
+
+/* If fewer than MIN_GC_YIELD cells are recovered during a garbage
+ collection (GC) more space is allocated for the heap. */
+
+#define MIN_GC_YIELD (heap_size/4)
+
+/* Define BIGDIG to an integer type whose size is smaller than long if
+ you want bignums. BIGRAD is one greater than the biggest BIGDIG. */
+/* Define DIGSTOOBIG if the digits equivalent to a long won't fit in a long. */
+#ifdef BIGNUMS
+# ifdef _UNICOS
+# define DIGSTOOBIG
+# if (1L << 31) <= USHRT_MAX
+# define BIGDIG unsigned short
+# else
+# define BIGDIG unsigned int
+# endif
+# define BITSPERDIG 32
+# else
+# define BIGDIG unsigned short
+# define BITSPERDIG (sizeof(BIGDIG)*CHAR_BIT)
+# endif
+# define BIGRAD (1L << BITSPERDIG)
+# define DIGSPERLONG ((sizet)((sizeof(long)*CHAR_BIT+BITSPERDIG-1)/BITSPERDIG))
+# define BIGUP(x) ((unsigned long)(x) << BITSPERDIG)
+# define BIGDN(x) ((x) >> BITSPERDIG)
+# define BIGLO(x) ((x) & (BIGRAD-1))
+#endif
+
+#ifndef BIGDIG
+# ifndef FLOATS
+# define INUMS_ONLY
+# endif
+#endif
+
+#ifdef NON_PREEMPTIVE
+# define DEFER_INTS /**/
+# ifdef TICKS
+# define POLL {if (0==poll_count--) poll_routine(); \
+ if (0==tick_count--) tick_signal();}
+# else
+# define POLL {if (0==poll_count--) poll_routine();}
+# endif
+# define CHECK_INTS POLL
+# define ALLOW_INTS POLL
+#else
+# ifdef CAREFUL_INTS
+# define DEFER_INTS {if (ints_disabled) \
+ fputs("ints already disabled\n", stderr); \
+ ints_disabled = 1;}
+# define ALLOW_INTS {if (!ints_disabled) \
+ fputs("ints already enabled\n", stderr); \
+ ints_disabled = 0;CHECK_INTS}
+# else
+# define DEFER_INTS {ints_disabled = 1;}
+# define ALLOW_INTS {ints_disabled = 0;CHECK_INTS}
+# endif
+# ifdef TICKS
+# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();\
+ POLL;}
+# define POLL {if (0==tick_count--) tick_signal();}
+# else
+# define CHECK_INTS {if (sig_deferred) han_sig();if (alrm_deferred) han_alrm();}
+# define POLL /**/
+# endif
+#endif
+
+#ifdef STACK_LIMIT
+# define CHECK_STACK {stack_check();}
+#else
+# define CHECK_STACK /**/
+#endif
+
+/* Cray machines have pointers that are incremented once for each word,
+ rather than each byte, the 3 most significant bits encode the byte
+ within the word. The following macros deal with this by storing the
+ native Cray pointers like the ones that looks like scm expects. This
+ is done for any pointers that might appear in the car of a cell, pointers
+ to vector elts, functions, &c are not munged. */
+#ifdef _UNICOS
+# define SCM2PTR(x) ((int)(x) >> 3)
+# define PTR2SCM(x) (((SCM)(x)) << 3)
+# define POINTERS_MUNGED
+#else
+# define SCM2PTR(x) (x)
+# define PTR2SCM(x) ((SCM)(x))
+#endif
+
+/* FIXABLE is non-null if its long argument can be encoded in an INUM. */
+
+#define POSFIXABLE(n) ((n) <= MOST_POSITIVE_FIXNUM)
+#define NEGFIXABLE(n) ((n) >= MOST_NEGATIVE_FIXNUM)
+#define UNEGFIXABLE(n) ((n) <= -MOST_NEGATIVE_FIXNUM)
+#define FIXABLE(n) (POSFIXABLE(n) && NEGFIXABLE(n))
+
+/* The following 8 definitions are defined automatically by the C
+ pre-processor. You will need to override these if you are
+ cross-compiling or if the C pre-processor has different properties
+ than the compiler. */
+
+#if (((-1)%2==-1) && ((-1)%(-2)==-1) && (1%2==1) && (1%(-2)==1))
+#else
+# define BADIVSGNS
+#endif
+
+/* SRS is signed right shift */
+/*--- Turbo C++ v1.0 has a bug with right shifts of signed longs!
+ It is believed to be fixed in Turbo C++ v1.01 ---*/
+#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295)
+# define SRS(x, y) ((x)>>y)
+# ifdef __TURBOC__
+# define INUM(x) (((x)>>1)>>1)
+# else
+# define INUM(x) SRS(x, 2)
+# endif
+#else
+# define SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y)
+# define INUM(x) SRS(x, 2)
+#endif
+
+#ifdef __TURBOC__
+/* shifts of more than one are done by a library call, single shifts are
+ performed in registers */
+# define MAKINUM(x) ((((x)<<1)<<1)+2L)
+#else
+# define MAKINUM(x) (((x)<<2)+2L)
+#endif
+
+#ifdef _DCC
+# define ASCII
+#else
+# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
+# define EBCDIC
+# endif
+# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
+# define ASCII
+# endif
+#endif
+
+/* CHAR_CODE_LIMIT is the number of distinct characters represented by
+ the unsigned char datatype. */
+/* MOST_POSITIVE_FIXNUM is the INUM closest to positive infinity. */
+/* MOST_NEGATIVE_FIXNUM is the INUM closest to negative infinity. */
+
+#ifdef __STDC__
+# define HAVE_LIMITSH
+#endif
+#ifdef MWC
+# define HAVE_LIMITSH
+#endif
+
+#ifdef HAVE_LIMITSH
+# include <limits.h>
+# ifdef UCHAR_MAX
+# define CHAR_CODE_LIMIT (UCHAR_MAX+1L)
+# else
+# define CHAR_CODE_LIMIT 256L
+# endif
+# define MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
+# ifdef _UNICOS /* Stupid cray bug */
+# define MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4)
+# else
+# define MOST_NEGATIVE_FIXNUM SRS((long)LONG_MIN, 2)
+# endif /* UNICOS */
+#else
+# define CHAR_CODE_LIMIT 256L
+# define MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3))
+# if (0 != ~0)
+# define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM-1)
+# else
+# define MOST_NEGATIVE_FIXNUM (-MOST_POSITIVE_FIXNUM)
+# endif
+#endif
+
+/* INTBUFLEN is the maximum number of characters neccessary for the
+ printed or string representation of an exact number. */
+
+#ifndef CHAR_BIT
+# define CHAR_BIT 8
+#endif
+#ifndef LONG_BIT
+# define LONG_BIT (CHAR_BIT*sizeof(long)/sizeof(char))
+#endif
+#define INTBUFLEN (5+LONG_BIT)
+
+/* FLOBUFLEN is the maximum number of characters neccessary for the
+ printed or string representation of an inexact number. */
+
+#ifdef FLOATS
+# define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*CHAR_BIT*3+9)/10)
+#endif /* FLOATS */
+
+/* MAXEXP is the maximum double precision expontent */
+/* FLTMAX is less than or equal the largest single precision float */
+
+#ifdef FLOATS
+# ifdef STDC_HEADERS
+# ifndef GO32
+# include <float.h>
+# endif
+# endif
+# ifdef DBL_MAX_10_EXP
+# define MAXEXP DBL_MAX_10_EXP
+# else
+# define MAXEXP 308 /* IEEE doubles */
+# endif
+# ifdef FLT_MAX
+# define FLTMAX FLT_MAX
+# else
+# define FLTMAX 1e+23
+# endif
+#endif
+
+/* Only some machines have pipes */
+#ifdef _IBMR2
+# define unix
+# define STDC_HEADERS
+#endif
+#ifdef unix
+ /* DJGPP (gcc for i386) defines unix! */
+# ifndef GO32
+# define HAVE_PIPE
+# endif
+#endif
+
+/* IS_INF tests its floating point number for infiniteness */
+
+#ifndef IS_INF
+# define IS_INF(x) ((x)==(x)/2)
+#endif
+
+#ifndef THINK_C
+# ifdef __WINDOWS__ /* there should be a better flag for this. */
+# define PROT386
+# endif
+#endif
+
+/* PTR_LT defines how to compare two CELLPTRs (which may not be in the
+ same array). CELLPTR is a pointer to a cons cell which may be
+ compared or differenced. SCMPTR is used for stack bounds. */
+
+#if defined(__TURBOC__) && !defined(__TOS__)
+# ifdef PROT386
+typedef cell *CELLPTR;
+typedef SCM *SCMPTR;
+# define PTR_LT(x, y) (((long)(x)) < ((long)(y)))
+# else
+typedef cell huge *CELLPTR;
+typedef SCM huge *SCMPTR;
+# define PTR_LT(x, y) ((x) < (y))
+# endif
+#else /* not __TURBOC__ */
+typedef cell *CELLPTR;
+typedef SCM *SCMPTR;
+# ifdef nosve
+# define PTR_MASK 0xffffffffffff
+# define PTR_LT(x, y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK))
+# else
+# define PTR_LT(x, y) ((x) < (y))
+# endif
+#endif
+
+#ifdef STDC_HEADERS
+# include <stdlib.h>
+# ifdef AMIGA
+# include <stddef.h>
+# endif
+# define sizet size_t
+#else
+# ifdef _SIZE_T
+# define sizet size_t
+# else
+# define sizet unsigned int
+# endif
+#endif
+
+/* On VMS, GNU C's errno.h contains a special hack to get link attributes
+ for errno correct for linking to the C RTL. */
+
+#include <errno.h>
+
+/* SYSCALL retries system calls that have been interrupted (EINTR) */
+#ifdef vms
+# ifndef __GNUC__
+# include <ssdef.h>
+# define SYSCALL(line) do{errno = 0;line} \
+ while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3))
+# endif
+#endif
+
+#ifndef SYSCALL
+# ifdef EINTR
+# if (EINTR > 0)
+# define SYSCALL(line) do{errno = 0;line}while(EINTR==errno)
+# endif
+# endif
+#endif
+
+#ifndef SYSCALL
+# define SYSCALL(line) {line}
+#endif
+
+#ifndef MSDOS
+# ifdef ARM_ULIB
+ extern volatile int errno;
+# else
+ extern int errno;
+# endif
+#endif
+#ifdef __TURBOC__
+# if (__TURBOC__==1)
+ /* Needed for TURBOC V1.0 */
+ extern int errno;
+# endif
+#endif
+
+/* EXIT_SUCCESS is the default code to return from SCM if no errors
+ were encountered. EXIT_FAILURE is the default code to return from
+ SCM if errors were encountered. The return code can be explicitly
+ specified in a SCM program with (quit <n>). */
+
+#ifndef EXIT_SUCCESS
+# ifdef vms
+# define EXIT_SUCCESS 1
+# else
+# define EXIT_SUCCESS 0
+# endif
+#endif
+#ifndef EXIT_FAILURE
+# ifdef vms
+# define EXIT_FAILURE 2
+# else
+# define EXIT_FAILURE 1
+# endif
+#endif
+
+/* Yasuaki Honda */
+/* Think C lacks isascii macro */
+#ifdef THINK_C
+# define isascii(c) ((unsigned)(c) <= 0x7f)
+#endif
+#ifdef _DCC
+# define isascii(c) ((unsigned)(c) <= 0x7f)
+#endif
+
+/* end of automatic C pre-processor definitions */
diff --git a/setjump.h b/setjump.h
new file mode 100644
index 0000000..eb7e90b
--- /dev/null
+++ b/setjump.h
@@ -0,0 +1,122 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "setjump.h" memory and stack parameters.
+ Author: Aubrey Jaffer */
+
+/* CELL_UP and CELL_DN are used by init_heap_seg to find cell aligned inner
+ bounds for allocated storage */
+
+#ifdef PROT386
+/*in 386 protected mode we must only adjust the offset */
+#define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
+#define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
+#else
+#ifdef _UNICOS
+#define CELL_UP(p) (CELLPTR)(~1L & ((long)(p)+1L))
+#define CELL_DN(p) (CELLPTR)(~1L & (long)(p))
+#else
+#define CELL_UP(p) (CELLPTR)(~(sizeof(cell)-1L) & ((long)(p)+sizeof(cell)-1L))
+#define CELL_DN(p) (CELLPTR)(~(sizeof(cell)-1L) & (long)(p))
+#endif /* UNICOS */
+#endif /* PROT386 */
+
+/* These are parameters for controlling memory allocation. The heap
+ is the area out of which cons and object headers is allocated.
+ Each heap object is 8 bytes on a 32 bit machine and 16 bytes on a
+ 64 bit machine. The units of the _SIZE parameters are bytes.
+
+ INIT_HEAP_SIZE is the initial size of heap. If this much heap is
+ allocated initially the heap will grow by half its current size
+ each subsequent time more heap is needed.
+
+ If INIT_HEAP_SIZE heap cannot be allocated initially, HEAP_SEG_SIZE
+ will be used, and the heap will grow by HEAP_SEG_SIZE when more
+ heap is needed. HEAP_SEG_SIZE must fit into type sizet. This code
+ is in init_storage() and alloc_some_heap() in sys.c
+
+ If INIT_HEAP_SIZE can be allocated initially, the heap will grow by
+ EXPHEAP(heap_size) when more heap is needed.
+
+ MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
+ is needed.
+
+ INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
+ trigger a GC. */
+
+#define INIT_HEAP_SIZE (25000L*sizeof(cell))
+#define MIN_HEAP_SEG_SIZE (2000L*sizeof(cell))
+#ifdef _QC
+#define HEAP_SEG_SIZE 32400L
+#else
+#ifdef sequent
+#define HEAP_SEG_SIZE (7000L*sizeof(cell))
+#else
+#define HEAP_SEG_SIZE (8100L*sizeof(cell))
+#endif
+#endif
+#define EXPHEAP(heap_size) (heap_size*2)
+#define INIT_MALLOC_LIMIT 100000
+
+#ifdef IN_CONTINUE_C
+# include "scm.h"
+# define malloc(size) must_malloc((long)(size), s_cont)
+# define free(obj) must_free((char *)(obj))
+#endif
+
+/* other.dynenv and other.parent get GCed just by being there. */
+struct scm_other {SCM dynenv;
+ SCM parent;
+#ifdef CAUTIOUS
+ SCM stack_trace;
+#endif
+ };
+#define CONTINUATION_OTHER struct scm_other
+#define CONT(x) ((CONTINUATION *)CDR(x))
+#define SETCONT SETCDR
+void dowinds P((SCM to, long delta));
+
+#include "continue.h"
+
+/* See scm.h for definition of P */
+void mark_locations P((STACKITEM x [], sizet n ));
+void scm_dynthrow P((CONTINUATION *cont, SCM val));
+#define s_cont (ISYMCHARS(IM_CONT)+20)
diff --git a/setjump.mar b/setjump.mar
new file mode 100644
index 0000000..2b49243
--- /dev/null
+++ b/setjump.mar
@@ -0,0 +1,38 @@
+ .title setjump and longjump
+; The VAX C runtime library uses the $unwind utility for implementing
+; longjmp. That fails if your program do not follow normal
+; stack decipline. This is a dirty implementation of setjmp
+; and longjmp that does not have that problem.
+; the names longjmp and setjmp are avoided so that the code can be linked
+; with the vax c runtime library without name clashes.
+
+; This code was contributed by an anonymous reviewer from
+; comp.sources.reviewed.
+
+ .entry setjump,^M<IV>
+ movl 4(ap),r0
+ movq r2,(r0)+
+ movq r4,(r0)+
+ movq r6,(r0)+
+ movq r8,(r0)+
+ movq r10,(r0)+
+ movl fp,(r0)+
+ movo 4(fp),(r0)+
+ movq 20(fp),(r0)
+ clrl r0
+ ret
+
+ .entry longjump,^M<IV>
+ movl 4(ap),r0
+ movq (r0)+,r2
+ movq (r0)+,r4
+ movq (r0)+,r6
+ movq (r0)+,r8
+ movq (r0)+,r10
+ movl (r0)+,r1
+ movo (r0)+,4(r1)
+ movq (r0),20(r1)
+ movl 8(ap),r0
+ movl r1,fp
+ ret
+ .end
diff --git a/setjump.s b/setjump.s
new file mode 100644
index 0000000..b96fb05
--- /dev/null
+++ b/setjump.s
@@ -0,0 +1,40 @@
+* setjmp on the Cray YMP does not save all registers. Although this
+* conforms to the ANSI standard, it is not sufficient for SCM garbage
+* collection and continuations.
+*
+* This is a version of setjump for the Cray YMP that does save all non-
+* temporary registers. It might work for the XMP. It definitely will
+* not work on the Cray 2. I do not know if the setjmp on the Cray 2 will
+* work with SCM or not.
+*
+* This has been tested under Unicos 6.1.
+*
+* --Radey Shouman <rshouman@chpc.utexas.edu>
+*
+ IDENT SETJUMP
+ ENTRY setjump
+setjump = *
+ A1 1,A6
+ A2 56
+ A0 A1
+ ,A0 T00,A2
+ A0 A1+A2
+ ,A0 B00,A2
+ S1 0
+ J B00
+*
+ ENTRY longjump
+longjump = *
+ A1 1,A6
+ A0 A1
+ A2 56
+ T00,A2 ,A0
+ A0 A1+A2
+ B00,A2 ,A0
+ S1 2,A6
+ J B00
+ END
+** Local Variables:
+** tab-stop-list: (12 28 45)
+** indent-tabs-mode: nil
+** End:
diff --git a/socket.c b/socket.c
new file mode 100644
index 0000000..4446253
--- /dev/null
+++ b/socket.c
@@ -0,0 +1,635 @@
+/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "socket.c" internet stream socket support for client/server in SCM
+ Author: Aubrey Jaffer.
+ Thanks to Hallvard.Tretteberg@si.sintef.no
+ who credits NCSA httpd software by Rob McCool 3/21/93
+*/
+
+#include "scm.h"
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <netinet/in.h>
+#include <netdb.h>
+#include <arpa/inet.h>
+
+#ifndef STDC_HEADERS
+ int close P((int fd));
+#endif /* STDC_HEADERS */
+
+static char s_inetaddr[] = "inet:string->address";
+SCM l_inetaddr (host)
+ SCM host;
+{
+ struct in_addr soka;
+ ASSERT(NIMP(host) && STRINGP(host), host, ARG1, s_inetaddr);
+ soka.s_addr = inet_addr(CHARS(host));
+ if (-1==soka.s_addr) {
+ struct hostent *entry;
+ DEFER_INTS;
+ SYSCALL(entry = gethostbyname(CHARS(host)););
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ return ulong2num(ntohl(((struct in_addr *)entry->h_addr)->s_addr));
+ }
+ return ulong2num(ntohl(soka.s_addr));
+}
+
+static char s_inetstr[] = "inet:address->string";
+SCM l_inetstr (inetid)
+ SCM inetid;
+{
+ struct in_addr addr;
+ char *ans;
+ addr.s_addr = htonl(num2ulong(inetid, (char *)ARG1, s_inetstr));
+ SYSCALL(ans = inet_ntoa(addr););
+ return makfrom0str(ans);
+}
+
+static char s_network[] = "inet:network";
+SCM l_network (host)
+ SCM host;
+{
+ struct in_addr addr;
+ addr.s_addr = htonl(num2ulong(host, (char *)ARG1, s_network));
+ return ulong2num(0L+inet_netof(addr));
+}
+
+static char s_lna[] = "inet:local-network-address";
+SCM l_lna (host)
+ SCM host;
+{
+ struct in_addr addr;
+ addr.s_addr = htonl(num2ulong(host, (char *)ARG1, s_lna));
+ return ulong2num(0L+inet_lnaof(addr));
+}
+
+static char s_makaddr[] = "inet:make-address";
+SCM l_makaddr (net, lna)
+ SCM net, lna;
+{
+ struct in_addr addr;
+ unsigned long netnum = num2ulong(net, (char *)ARG1, s_makaddr);
+ unsigned long lnanum = num2ulong(lna, (char *)ARG2, s_makaddr);
+ addr = inet_makeaddr(netnum, lnanum);
+ return ulong2num(ntohl(addr.s_addr));
+}
+
+static char s_hostinfo[] = "gethost";
+SCM l_hostinfo(name)
+ SCM name;
+{
+ SCM ans = make_vector(MAKINUM(5), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ SCM lst = EOL;
+ struct hostent *entry;
+ struct in_addr inad;
+ char **argv;
+ int i = 0;
+#ifndef linux
+ if UNBNDP(name) {
+ DEFER_INTS;
+ SYSCALL(entry = gethostent(););
+ }
+ else
+#endif
+ if (NIMP(name) && STRINGP(name)) {
+ DEFER_INTS;
+ SYSCALL(entry = gethostbyname(CHARS(name)););
+ }
+ else {
+ inad.s_addr = htonl(num2ulong(name, (char *)ARG1, s_hostinfo));
+ DEFER_INTS;
+ SYSCALL(entry = gethostbyaddr((char *)&inad , sizeof(inad), AF_INET););
+ }
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->h_name);
+ ve[ 1] = makfromstrs(-1, entry->h_aliases);
+ ve[ 2] = MAKINUM(entry->h_addrtype + 0L);
+ ve[ 3] = MAKINUM(entry->h_length + 0L);
+ if (sizeof(struct in_addr) != entry->h_length)
+ {ve[ 4] = BOOL_F; return ans;}
+ for(argv = entry->h_addr_list; argv[i]; i++);
+ while (i--) {
+ inad = *(struct in_addr *)argv[i];
+ lst = cons(ulong2num(ntohl(inad.s_addr)), lst);
+ }
+ ve[ 4] = lst;
+ return ans;
+}
+static char s_netinfo[] = "getnet";
+SCM l_netinfo(name)
+ SCM name;
+{
+ SCM ans = make_vector(MAKINUM(4), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ struct netent *entry;
+ if UNBNDP(name) {
+ DEFER_INTS;
+ SYSCALL(entry = getnetent(););
+ }
+ else if (NIMP(name) && STRINGP(name)) {
+ DEFER_INTS;
+ SYSCALL(entry = getnetbyname(CHARS(name)););
+ }
+ else {
+ unsigned long netnum;
+ netnum = num2ulong(name, (char *)ARG1, s_netinfo);
+ DEFER_INTS;
+ SYSCALL(entry = getnetbyaddr(netnum, AF_INET););
+ }
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->n_name);
+ ve[ 1] = makfromstrs(-1, entry->n_aliases);
+ ve[ 2] = MAKINUM(entry->n_addrtype + 0L);
+ ve[ 3] = ulong2num(entry->n_net + 0L);
+ return ans;
+}
+static char s_protoinfo[] = "getproto";
+SCM l_protoinfo(name)
+ SCM name;
+{
+ SCM ans = make_vector(MAKINUM(3), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ struct protoent *entry;
+ if UNBNDP(name) {
+ DEFER_INTS;
+ SYSCALL(entry = getprotoent(););
+ }
+ else if (NIMP(name) && STRINGP(name)) {
+ DEFER_INTS;
+ SYSCALL(entry = getprotobyname(CHARS(name)););
+ }
+ else {
+ unsigned long protonum;
+ protonum = num2ulong(name, (char *)ARG1, s_protoinfo);
+ DEFER_INTS;
+ SYSCALL(entry = getprotobynumber(protonum););
+ }
+ ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->p_name);
+ ve[ 1] = makfromstrs(-1, entry->p_aliases);
+ ve[ 2] = MAKINUM(entry->p_proto + 0L);
+ return ans;
+}
+static char s_servinfo[] = "getserv";
+SCM l_servinfo(args)
+ SCM args;
+{
+ SCM ans = make_vector(MAKINUM(4), UNSPECIFIED);
+ SCM *ve = VELTS(ans);
+ SCM name, proto;
+ struct servent *entry;
+ if NULLP(args) {
+ DEFER_INTS;
+ SYSCALL(entry = getservent(););
+ goto comlab;
+ }
+ name = CAR(args);
+ proto = CDR(args);
+ ASSERT(NIMP(proto) && CONSP(proto), args, WNA, s_servinfo);
+ proto = CAR(proto);
+ ASSERT(NIMP(proto) && STRINGP(proto), args, ARG2, s_servinfo);
+ DEFER_INTS;
+ if (NIMP(name) && STRINGP(name))
+ SYSCALL(entry = getservbyname(CHARS(name), CHARS(proto)););
+ else {
+ ASSERT(INUMP(proto), proto, ARG1, s_servinfo);
+ SYSCALL(entry = getservbyport(INUM(proto), CHARS(proto)););
+ }
+ comlab: ALLOW_INTS;
+ if (!entry) return BOOL_F;
+ ve[ 0] = makfrom0str(entry->s_name);
+ ve[ 1] = makfromstrs(-1, entry->s_aliases);
+ ve[ 2] = MAKINUM(ntohs(entry->s_port) + 0L);
+ ve[ 3] = makfrom0str(entry->s_proto);
+ return ans;
+}
+
+SCM l_sethost(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) endhostent();
+ else sethostent(NFALSEP(arg));
+ return UNSPECIFIED;
+}
+SCM l_setnet(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) endnetent();
+ else setnetent(NFALSEP(arg));
+ return UNSPECIFIED;
+}
+SCM l_setproto(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) endprotoent();
+ else setprotoent(NFALSEP(arg));
+ return UNSPECIFIED;
+}
+SCM l_setserv(arg)
+ SCM arg;
+{
+ if UNBNDP(arg) endservent();
+ else setservent(NFALSEP(arg));
+ return UNSPECIFIED;
+}
+
+static char s_socket[] = "make-stream-socket";
+SCM l_socket(fam, proto)
+ SCM fam, proto;
+{
+ int sd, j, tp = INUM(fam);
+ FILE* f;
+ SCM port;
+ ASSERT(INUMP(fam), fam, ARG1, s_socket);
+ if UNBNDP(proto) proto = INUM0;
+ else ASSERT(INUMP(proto), proto, ARG2, s_socket);
+ NEWCELL(port);
+ DEFER_INTS;
+ SYSCALL(sd = socket(tp, SOCK_STREAM, INUM(proto)););
+ if (-1==sd) wta(UNDEFINED, (char *)NALLOC, s_socket);
+ SYSCALL(f = fdopen(sd, "r+"););
+ if (!f) {
+ close(sd);
+ wta(MAKINUM(sd), (char *)NALLOC, s_port_type);
+ }
+ CAR(port) = tc_socket | (tp<<24) | BUF0;
+ SETSTREAM(port, f);
+ i_setbuf0(port);
+ ALLOW_INTS;
+ if (AF_INET==tp) {
+ sd = setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &j, sizeof(j));
+ ASSERT(!sd, port, "could not set socket option", s_socket);
+ }
+ return port;
+}
+static char s_socketpair[] = "make-stream-socketpair";
+SCM l_socketpair(fam, proto)
+ SCM fam, proto;
+{
+ int sts, tp = INUM(fam);
+ int sv[2];
+ FILE* f[2];
+ SCM port[2];
+ ASSERT(INUMP(fam), fam, ARG1, s_socketpair);
+ if UNBNDP(proto) proto = INUM0;
+ else ASSERT(INUMP(proto), proto, ARG2, s_socketpair);
+ NEWCELL(port[0]); NEWCELL(port[1]);
+ DEFER_INTS;
+ SYSCALL(sts = socketpair(tp, SOCK_STREAM, INUM(proto), sv););
+ if (-1==sts) wta(UNDEFINED, (char *)NALLOC, s_socketpair);
+ SYSCALL(f[0] = fdopen(sv[0], "r+"););
+ if (!f[0]) {
+ close(sv[0]);
+ wta(MAKINUM(sv[0]), (char *)NALLOC, s_port_type);
+ }
+ SYSCALL(f[1] = fdopen(sv[1], "r+"););
+ if (!f[1]) {
+ fclose(f[0]);
+ close(sv[1]);
+ wta(MAKINUM(sv[1]), (char *)NALLOC, s_port_type);
+ }
+ CAR(port[0]) = CAR(port[1]) = tc16_fport | mode_bits("r+0");
+ SETSTREAM(port[0], f[0]); SETSTREAM(port[1], f[1]);
+ i_setbuf0(port[0]); i_setbuf0(port[1]);
+ ALLOW_INTS;
+ return cons(port[0], port[1]);
+}
+
+static char s_shutdown[] = "socket:shutdown";
+SCM l_shutdown(port, how)
+ SCM port, how;
+{
+ int sts;
+ ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_shutdown);
+ ASSERT(INUMP(how) && 0 <= INUM(how) && 2 >= INUM(how),
+ how, ARG2, s_shutdown);
+ SYSCALL(sts = shutdown(fileno(STREAM(port)), INUM(how)););
+ if (sts) return BOOL_F;
+ switch (INUM(how)) {
+ case 0: CAR(port) &= ~RDNG;
+ break;
+ case 1: CAR(port) &= ~WRTNG;
+ break;
+ case 2: CAR(port) &= ~(RDNG | WRTNG);
+ }
+ if SOCKP(port) close_port(port); /* can't read or write */
+ return port;
+}
+static char s_unkfam[] = "unknown-family";
+static char s_connect[] = "socket:connect";
+SCM l_connect (sockpt, address, arg)
+ SCM sockpt, address, arg;
+{
+ int sts;
+ ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect);
+ switch SOCKTYP(sockpt) {
+ default:
+ ASSERT(0, sockpt, s_unkfam, s_connect);
+ case AF_INET:
+ ASSERT(NIMP(arg) && CONSP(arg) && NULLP(CDR(arg)), arg, WNA, s_connect);
+ arg = CAR(arg);
+ ASSERT(INUMP(arg), arg, ARG3, s_connect);
+ {
+ struct sockaddr_in soka;
+ soka.sin_addr.s_addr =
+ htonl(num2ulong(address, (char *)ARG2, s_connect));
+ soka.sin_family = AF_INET;
+ soka.sin_port = htons(INUM(arg));
+ SYSCALL(sts = connect(fileno(STREAM(sockpt)),
+ (struct sockaddr*)&soka, sizeof(soka)););
+ }
+ break;
+ case AF_UNIX:
+ ASSERT(NULLP(arg), arg, WNA, s_connect);
+ ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_connect);
+ {
+ struct sockaddr_un soka;
+ soka.sun_family = AF_UNIX;
+ memcpy(&soka.sun_path, CHARS(address), 1+LENGTH(address));
+ SYSCALL(sts = connect(fileno(STREAM(sockpt)),
+ (struct sockaddr*)&soka, sizeof(soka)););
+ }
+ break;
+ }
+ if (sts) return BOOL_F;
+ CAR(sockpt) = tc16_fport | mode_bits("r+0");
+ return sockpt;
+}
+
+static char s_bind[] = "socket:bind";
+SCM l_bind(sockpt, address)
+ SCM sockpt, address;
+{
+ int sts;
+ ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_bind);
+ switch SOCKTYP(sockpt) {
+ default:
+ ASSERT(0, sockpt, s_unkfam, s_bind);
+ case AF_UNIX:
+ ASSERT(NIMP(address) && STRINGP(address), address, ARG2, s_bind);
+ {
+ struct sockaddr_un sa_server;
+ bzero((char *) &sa_server, sizeof(sa_server));
+ sa_server.sun_family = AF_UNIX;
+ memcpy(&sa_server.sun_path, CHARS(address), 1+LENGTH(address));
+ SYSCALL(sts = bind(fileno(STREAM(sockpt)),
+ (struct sockaddr *)&sa_server, sizeof(sa_server)););
+ }
+ break;
+ case AF_INET:
+ ASSERT(INUMP(address), address, ARG2, s_bind);
+ {
+ struct sockaddr_in sa_server;
+ bzero((char *) &sa_server, sizeof(sa_server));
+ sa_server.sin_family = AF_INET;
+ sa_server.sin_addr.s_addr = htonl(INADDR_ANY);
+ sa_server.sin_port = htons(INUM(address));
+ SYSCALL(sts = bind(fileno(STREAM(sockpt)),
+ (struct sockaddr *)&sa_server, sizeof(sa_server)););
+ }
+ break;
+ }
+ return sts ? BOOL_F : sockpt;
+}
+
+static char s_listen[] = "socket:listen";
+SCM l_listen(port, backlog)
+ SCM port, backlog;
+{
+ int sts;
+ ASSERT(NIMP(port) && SOCKP(port), port, ARG1, s_listen);
+ ASSERT(INUMP(backlog), backlog, ARG2, s_listen);
+ SYSCALL(sts = listen(fileno(STREAM(port)), INUM(backlog)););
+ if (sts) return BOOL_F;
+ CAR(port) = tc16_fport | mode_bits("r0");
+ return port;
+}
+
+static char s_accept[] = "socket:accept";
+SCM l_accept(sockpt)
+ SCM sockpt;
+{
+ int newsd, sadlen;
+ struct sockaddr sad;
+ FILE *newfd;
+ SCM newpt;
+ NEWCELL(newpt);
+ ASSERT(NIMP(sockpt) && OPINPORTP(sockpt), sockpt, ARG1, s_accept);
+ sadlen=sizeof(sad);
+ DEFER_INTS;
+ SYSCALL(newsd = accept(fileno(STREAM(sockpt)), &sad, &sadlen););
+ if (-1==newsd)
+ if (EWOULDBLOCK != errno) return BOOL_F;
+ else wta(sockpt, "couldn't", s_accept);
+ SYSCALL(newfd = fdopen(newsd, "r+"););
+ if (!newfd) {
+ close(newsd);
+ wta(MAKINUM(newsd), (char *)NALLOC, s_port_type);
+ }
+ CAR(newpt) = tc16_fport | mode_bits("r+0");
+ SETSTREAM(newpt, newfd);
+ i_setbuf0(newpt);
+ ALLOW_INTS;
+ return newpt;
+}
+
+int sknm_print(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ lputs("#<", port);
+ switch (((struct sockaddr *)CDR(exp))->sa_family) {
+ case AF_UNIX:
+ lputs("unix-addr ", port);
+ lputs(((struct sockaddr_un *)CDR(exp))->sun_path, port);
+ break;
+ case AF_INET:
+ lputs("inet-addr ", port);
+ lputs(inet_ntoa(((struct sockaddr_in *)CDR(exp))->sin_addr), port);
+ lputc(':', port);
+ intprint(0L + ntohs(((struct sockaddr_in *)CDR(exp))->sin_port), 10, port);
+ break;
+ default: lputs(s_unkfam, port);
+ lputc(' ', port);
+ intprint(0L+((struct sockaddr *)CDR(exp))->sa_family, 10, port);
+ }
+ lputc('>', port);
+ return !0;
+}
+sizet sknm_free(p)
+ CELLPTR p;
+{
+ must_free(CHARS((SCM)p));
+ return sizeof(struct sockaddr);
+}
+long tc16_sknm;
+static smobfuns sknm_smob = {mark0, sknm_free, sknm_print, 0};
+
+char s_sknm_family[] = "socket-name:family";
+SCM l_sknm_family(snm)
+ SCM snm;
+{
+ ASSERT(NIMP(snm) && TYP16(snm)==tc16_sknm, snm, ARG1, s_sknm_family);
+ return MAKINUM(((struct sockaddr *)CDR(snm))->sa_family + 0L);
+}
+char s_sknm_port_num[] = "socket-name:port-number";
+SCM l_sknm_port_num(snm)
+ SCM snm;
+{
+ ASRTGO(NIMP(snm) && TYP16(snm)==tc16_sknm, err1);
+ switch (((struct sockaddr *)CDR(snm))->sa_family) {
+ default:
+ err1:
+ wta(snm, (char *)ARG1, s_sknm_port_num);
+ case AF_INET:
+ return MAKINUM(ntohs(((struct sockaddr_in *)CDR(snm))->sin_port) + 0L);
+ }
+}
+char s_sknm_addr[] = "socket-name:address";
+SCM l_sknm_addr(snm)
+ SCM snm;
+{
+ ASRTGO(NIMP(snm) && TYP16(snm)==tc16_sknm, err1);
+ switch (((struct sockaddr *)CDR(snm))->sa_family) {
+ default:
+ err1:
+ wta(snm, (char *)ARG1, s_sknm_addr);
+ case AF_INET:
+ return ulong2num(ntohl(((struct sockaddr_in *)CDR(snm))->sin_addr.s_addr));
+ case AF_UNIX: /* the manual says this won't work anyway */
+ return makfrom0str(((struct sockaddr_un *)CDR(snm))->sun_path);
+ }
+}
+
+SCM maksknm(sad)
+ struct sockaddr *sad;
+{
+ SCM sknm;
+ struct sockaddr *msknm;
+ NEWCELL(sknm);
+ DEFER_INTS;
+ msknm = (struct sockaddr *)must_malloc(0L+sizeof(struct sockaddr), "sknm");
+ *msknm = *sad;
+ CAR(sknm) = tc16_sknm;
+ SETCDR(sknm, msknm);
+ ALLOW_INTS;
+ return sknm;
+}
+
+static char s_getpeername[] = "getpeername";
+SCM l_getpeername(sockpt)
+ SCM sockpt;
+{
+ struct sockaddr_in sad;
+ int sts, sadlen = sizeof(sad);
+ bzero((char *) &sad, sizeof(sad));
+ ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getpeername);
+ SYSCALL(sts = getpeername(fileno(STREAM(sockpt)),
+ (struct sockaddr*)&sad, &sadlen););
+ if (sts || sizeof(sad) != sadlen) return BOOL_F;
+/* ASSERT(sad.sin_family==AF_INET, sockpt, "non-internet", s_getpeername); */
+ return maksknm(&sad);
+}
+static char s_getsockname[] = "getsockname";
+SCM l_getsockname(sockpt)
+ SCM sockpt;
+{
+ struct sockaddr_in sad;
+ int sts, sadlen = sizeof(sad);
+ bzero((char *) &sad, sizeof(sad));
+ ASSERT(NIMP(sockpt) && OPPORTP(sockpt), sockpt, ARG1, s_getsockname);
+ SYSCALL(sts = getsockname(fileno(STREAM(sockpt)),
+ (struct sockaddr*)&sad, &sadlen););
+ if (sts || sizeof(sad) != sadlen) return BOOL_F;
+ return maksknm(&sad);
+}
+static iproc subr1s[] = {
+ {s_inetaddr, l_inetaddr},
+ {s_inetstr, l_inetstr},
+ {s_network, l_network},
+ {s_lna, l_lna},
+ {s_makaddr, l_makaddr},
+
+ {s_accept, l_accept},
+ {s_sknm_family, l_sknm_family},
+ {s_sknm_port_num, l_sknm_port_num},
+ {s_sknm_addr, l_sknm_addr},
+ {s_getpeername, l_getpeername},
+ {s_getsockname, l_getsockname},
+ {0, 0}};
+
+static iproc subr1os[] = {
+ {s_hostinfo, l_hostinfo},
+ {s_netinfo, l_netinfo},
+ {s_protoinfo, l_protoinfo},
+ {"sethostent", l_sethost},
+ {"setnetent", l_setnet},
+ {"setprotoent", l_setproto},
+ {"setservent", l_setserv},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_shutdown, l_shutdown},
+ {s_bind, l_bind},
+ {s_listen, l_listen},
+ {s_makaddr, l_makaddr},
+ {0, 0}};
+
+void init_socket()
+{
+ sysintern("af_unix", MAKINUM(AF_UNIX));
+ sysintern("af_inet", MAKINUM(AF_INET));
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr1os, tc7_subr_1o);
+ init_iprocs(subr2s, tc7_subr_2);
+ make_subr(s_servinfo, tc7_lsubr, l_servinfo);
+ make_subr(s_socket, tc7_subr_2o, l_socket);
+ make_subr(s_socketpair, tc7_subr_2o, l_socketpair);
+ make_subr(s_connect, tc7_lsubr_2, l_connect);
+ tc16_sknm = newsmob(&sknm_smob);
+ add_feature("socket");
+}
diff --git a/split.scm b/split.scm
new file mode 100644
index 0000000..1230946
--- /dev/null
+++ b/split.scm
@@ -0,0 +1,87 @@
+;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of GUILE.
+;;
+;; The exception is that, if you link the GUILE library with other files
+;; to produce an executable, this does not by itself cause the
+;; resulting executable to be covered by the GNU General Public License.
+;; Your use of that executable is in no way restricted on account of
+;; linking the GUILE library code into it.
+;;
+;; This exception does not however invalidate any other reasons why
+;; the executable file might be covered by the GNU General Public License.
+;;
+;; This exception applies only to the code released by the
+;; Free Software Foundation under the name GUILE. If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, as the General Public License permits, the exception does
+;; not apply to the code that you add in this way. To avoid misleading
+;; anyone as to the status of such modified files, you must delete
+;; this exception notice from them.
+;;
+;; If you write modifications of your own for GUILE, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "split.scm", split input, output, and error streams into windows.
+;;; Author: Aubrey Jaffer.
+
+(require 'curses)
+(define *stdscr* (initscr))
+(nocbreak)
+(echo)
+(nl)
+(define subwindow-height (max 2 (quotient (output-port-height) 5)))
+(define *output-window*
+ (newwin (- (output-port-height) (* 2 subwindow-height) 2)
+ (output-port-width)
+ 0
+ 0))
+(define *input-window*
+ (newwin subwindow-height
+ (output-port-width)
+ (- (output-port-height) (* 2 subwindow-height) 1)
+ 0))
+(define *error-window*
+ (newwin subwindow-height
+ (output-port-width)
+ (- (output-port-height) subwindow-height)
+ 0))
+(wmove *stdscr* (- (output-port-height) subwindow-height 1) 0)
+(wstandout *stdscr*)
+(display (make-string (output-port-width) #\-) *stdscr*)
+(wmove *stdscr* (- (output-port-height) (* 2 subwindow-height) 2) 0)
+(display (make-string (output-port-width) #\-) *stdscr*)
+(wstandend *stdscr*)
+(touchwin *stdscr*)
+(force-output *stdscr*)
+(scrollok *output-window* #t)
+(scrollok *input-window* #t)
+(scrollok *error-window* #t)
+(define *default-output-port* (set-current-output-port *output-window*))
+(define *default-input-port* (set-current-input-port *input-window*))
+(define *default-error-port* (set-current-error-port *error-window*))
+(leaveok *output-window* #t)
+(leaveok *input-window* #f)
+(leaveok *error-window* #t)
+
+(define (unsplit)
+ (cond ((endwin)
+ (set-current-output-port *default-output-port*)
+ (set-current-input-port *default-input-port*)
+ (set-current-error-port *default-error-port*))))
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 <ctype.h>
+#include "scm.h"
+
+#define s_length (s_st_length+7)
+#define s_append (s_st_append+7)
+
+char s_make_string[] = "make-string";
+char s_list[] = "list";
+
+static char s_setcar[] = "set-car!", s_setcdr[] = "set-cdr!",
+ s_reverse[] = "reverse", s_list_ref[] = "list-ref";
+static char s_memq[] = "memq", s_member[] = "member",
+ s_assq[] = "assq", s_assoc[] = "assoc";
+static char s_symbol2string[] = "symbol->string",
+ s_str2symbol[] = "string->symbol";
+extern char s_inexactp[];
+#define s_exactp (s_inexactp+2)
+static char s_oddp[] = "odd?", s_evenp[] = "even?";
+static char s_abs[] = "abs", s_quotient[] = "quotient",
+ s_remainder[] = "remainder", s_modulo[] = "modulo";
+static char s_gcd[] = "gcd";
+
+static char s_ci_eq[] = "char-ci=?",
+ s_ch_lessp[] = "char<?", s_ch_leqp[] = "char<=?",
+ s_ci_lessp[] = "char-ci<?", s_ci_leqp[] = "char-ci<=?",
+ s_ch_grp[] = "char>?", s_ch_geqp[] = "char>=?",
+ s_ci_grp[] = "char-ci>?", s_ci_geqp[] = "char-ci>=?";
+static char s_ch_alphap[] = "char-alphabetic?",
+ s_ch_nump[] = "char-numeric?",
+ s_ch_whitep[] = "char-whitespace?",
+ s_ch_upperp[] = "char-upper-case?",
+ s_ch_lowerp[] = "char-lower-case?";
+static char s_char2int[] = "char->integer", s_int2char[] = "integer->char",
+ s_ch_upcase[] = "char-upcase", s_ch_downcase[] = "char-downcase";
+
+static char s_st_length[] = "string-length",
+ s_st_ref[] = "string-ref", s_st_set[] = "string-set!";
+static char s_st_equal[] = "string=?", s_stci_equal[] = "string-ci=?",
+ s_st_lessp[] = "string<?", s_stci_lessp[] = "string-ci<?";
+static char s_substring[] = "substring", s_st_append[] = "string-append";
+
+static char s_ve_length[] = "vector-length",
+ s_ve_ref[] = "vector-ref", s_ve_set[] = "vector-set!";
+
+SCM lnot(x)
+ SCM x;
+{
+ return FALSEP(x) ? BOOL_T : BOOL_F;
+}
+SCM booleanp(obj)
+ SCM obj;
+{
+ if (BOOL_F==obj) return BOOL_T;
+ if (BOOL_T==obj) return BOOL_T;
+ return BOOL_F;
+}
+SCM eq(x, y)
+ SCM x, y;
+{
+ if (x==y) return BOOL_T;
+ else return BOOL_F;
+}
+
+SCM consp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return CONSP(x) ? BOOL_T : BOOL_F;
+}
+SCM setcar(pair, value)
+ SCM pair, value;
+{
+ ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
+ CAR(pair) = value;
+ return UNSPECIFIED;
+}
+SCM setcdr(pair, value)
+ SCM pair, value;
+{
+ ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
+ CDR(pair) = value;
+ return UNSPECIFIED;
+}
+SCM nullp(x)
+ SCM x;
+{
+ return NULLP(x) ? BOOL_T : BOOL_F;
+}
+long ilength(sx)
+ SCM sx;
+{
+ register long i = 0;
+ register SCM x = sx;
+ do {
+ if IMP(x) return NULLP(x) ? i : -1;
+ if NCONSP(x) return -2;
+ x = CDR(x);
+ i++;
+ if IMP(x) return NULLP(x) ? i : -1;
+ if NCONSP(x) return -2;
+ x = CDR(x);
+ i++;
+ sx = CDR(sx);
+ }
+ while (x != sx);
+ return -1;
+}
+SCM listp(x)
+ SCM x;
+{
+ if (ilength(x)<0) return BOOL_F;
+ else return BOOL_T;
+}
+SCM list(objs)
+ SCM objs;
+{
+ return objs;
+}
+SCM length(x)
+ SCM x;
+{
+ SCM i = MAKINUM(ilength(x));
+ ASSERT(i >= INUM0, x, ARG1, s_length);
+ return i;
+}
+SCM append(args)
+ SCM args;
+{
+ SCM res = EOL;
+ SCM *lloc = &res, arg;
+ if IMP(args) {
+ ASSERT(NULLP(args), args, ARGn, s_append);
+ return res;
+ }
+ ASSERT(CONSP(args), args, ARGn, s_append);
+ while (1) {
+ arg = CAR(args);
+ args = CDR(args);
+ if IMP(args) {
+ *lloc = arg;
+ ASSERT(NULLP(args), args, ARGn, s_append);
+ return res;
+ }
+ ASSERT(CONSP(args), args, ARGn, s_append);
+ for(;NIMP(arg);arg = CDR(arg)) {
+ ASSERT(CONSP(arg), arg, ARGn, s_append);
+ *lloc = cons(CAR(arg), EOL);
+ lloc = &CDR(*lloc);
+ }
+ ASSERT(NULLP(arg), arg, ARGn, s_append);
+ }
+}
+SCM reverse(lst)
+ SCM lst;
+{
+ SCM res = EOL;
+ SCM p = lst;
+ for(;NIMP(p);p = CDR(p)) {
+ ASSERT(CONSP(p), lst, ARG1, s_reverse);
+ res = cons(CAR(p), res);
+ }
+ ASSERT(NULLP(p), lst, ARG1, s_reverse);
+ return res;
+}
+SCM list_ref(lst, k)
+ SCM lst, k;
+{
+ register long i;
+ ASSERT(INUMP(k), k, ARG2, s_list_ref);
+ i = INUM(k);
+ ASSERT(i >= 0, k, ARG2, s_list_ref);
+ while (i-- > 0) {
+ ASRTGO(NIMP(lst) && CONSP(lst), erout);
+ lst = CDR(lst);
+ }
+erout: ASSERT(NIMP(lst) && CONSP(lst),
+ NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref);
+ return CAR(lst);
+}
+SCM memq(x, lst)
+ SCM x, lst;
+{
+ for(;NIMP(lst);lst = CDR(lst)) {
+ ASSERT(CONSP(lst), lst, ARG2, s_memq);
+ if (CAR(lst)==x) return lst;
+ }
+ ASSERT(NULLP(lst), lst, ARG2, s_memq);
+ return BOOL_F;
+}
+SCM member(x, lst)
+ SCM x, lst;
+{
+ for(;NIMP(lst);lst = CDR(lst)) {
+ ASSERT(CONSP(lst), lst, ARG2, s_member);
+ if NFALSEP(equal(CAR(lst), x)) return lst;
+ }
+ ASSERT(NULLP(lst), lst, ARG2, s_member);
+ return BOOL_F;
+}
+SCM assq(x, alist)
+ SCM x, alist;
+{
+ SCM tmp;
+ for(;NIMP(alist);alist = CDR(alist)) {
+ ASSERT(CONSP(alist), alist, ARG2, s_assq);
+ tmp = CAR(alist);
+ ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
+ if (CAR(tmp)==x) return tmp;
+ }
+ ASSERT(NULLP(alist), alist, ARG2, s_assq);
+ return BOOL_F;
+}
+SCM assoc(x, alist)
+ SCM x, alist;
+{
+ SCM tmp;
+ for(;NIMP(alist);alist = CDR(alist)) {
+ ASSERT(CONSP(alist), alist, ARG2, s_assoc);
+ tmp = CAR(alist);
+ ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
+ if NFALSEP(equal(CAR(tmp), x)) return tmp;
+ }
+ ASSERT(NULLP(alist), alist, ARG2, s_assoc);
+ return BOOL_F;
+}
+
+SCM symbolp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return SYMBOLP(x) ? BOOL_T : BOOL_F;
+}
+SCM symbol2string(s)
+ SCM s;
+{
+ ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
+ return makfromstr(CHARS(s), (sizet)LENGTH(s));
+}
+SCM string2symbol(s)
+ SCM s;
+{
+ ASSERT(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol);
+ s = intern(CHARS(s), (sizet)LENGTH(s));
+ return CAR(s);
+}
+
+SCM exactp(x)
+ SCM x;
+{
+ if INUMP(x) return BOOL_T;
+#ifdef BIGDIG
+ if (NIMP(x) && BIGP(x)) return BOOL_T;
+#endif
+ return BOOL_F;
+}
+SCM oddp(n)
+ SCM n;
+{
+#ifdef BIGDIG
+ if NINUMP(n) {
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
+ return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F;
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_oddp);
+#endif
+ return (4 & (int)n) ? BOOL_T : BOOL_F;
+}
+SCM evenp(n)
+ SCM n;
+{
+#ifdef BIGDIG
+ if NINUMP(n) {
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
+ return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T;
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_evenp);
+#endif
+ return (4 & (int)n) ? BOOL_F : BOOL_T;
+}
+SCM absval(x)
+ SCM x;
+{
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_abs);
+ if (TYP16(x)==tc16_bigpos) return x;
+ return copybig(x, 0);
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_abs);
+#endif
+ if (INUM(x) >= 0) return x;
+ x = -INUM(x);
+ if (!POSFIXABLE(x))
+#ifdef BIGDIG
+ return long2big(x);
+#else
+ wta(MAKINUM(-x), (char *)OVFLOW, s_abs);
+#endif
+ return MAKINUM(x);
+}
+SCM lquotient(x, y)
+ SCM x, y;
+{
+ register long z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ long w;
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y), 2);
+ }
+ z = INUM(y);
+ ASRTGO(z, ov);
+ if (1==z) return x;
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
+ divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z);
+ return normbig(w);
+ }
+# ifndef DIGSTOOBIG
+ w = pseudolong(z);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&w, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 2);
+# else
+ { BIGDIG zdigs[DIGSPERLONG];
+ longdigs(z, zdigs);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 2);
+ }
+# endif
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_quotient);
+# endif
+ return INUM0;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_quotient);
+ ASSERT(INUMP(y), y, ARG2, s_quotient);
+#endif
+ if ((z = INUM(y))==0)
+ ov: wta(y, (char *)OVFLOW, s_quotient);
+ z = INUM(x)/z;
+#ifdef BADIVSGNS
+ {
+# if (__TURBOC__==1)
+ long t = ((y<0) ? -INUM(x) : INUM(x))%INUM(y);
+# else
+ long t = INUM(x)%INUM(y);
+# endif
+ if (t==0) ;
+ else if (t < 0)
+ if (x < 0) ;
+ else z--;
+ else if (x < 0) z++;
+ }
+#endif
+ if (!FIXABLE(z))
+#ifdef BIGDIG
+ return long2big(z);
+#else
+ wta(x, (char *)OVFLOW, s_quotient);
+#endif
+ return MAKINUM(z);
+}
+SCM lremainder(x, y)
+ SCM x, y;
+{
+ register long z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x), 0);
+ }
+ if (!(z = INUM(y))) goto ov;
+ return divbigint(x, z, BIGSIGN(x), 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_remainder);
+# endif
+ return x;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_remainder);
+ ASSERT(INUMP(y), y, ARG2, s_remainder);
+#endif
+ if (!(z = INUM(y)))
+ ov: wta(y, (char *)OVFLOW, s_remainder);
+#if (__TURBOC__==1)
+ if (z < 0) z = -z;
+#endif
+ z = INUM(x)%z;
+#ifdef BADIVSGNS
+ if (!z) ;
+ else if (z < 0)
+ if (x < 0) ;
+ else z += INUM(y);
+ else if (x < 0) z -= INUM(y);
+#endif
+ return MAKINUM(z);
+}
+SCM modulo(x, y)
+ SCM x, y;
+{
+ register long yy, z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0);
+ }
+ if (!(z = INUM(y))) goto ov;
+ return divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_modulo);
+# endif
+ return (BIGSIGN(y) ? (x>0) : (x<0)) ? sum(x, y) : x;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_modulo);
+ ASSERT(INUMP(y), y, ARG2, s_modulo);
+#endif
+ if (!(yy = INUM(y)))
+ ov: wta(y, (char *)OVFLOW, s_modulo);
+#if (__TURBOC__==1)
+ z = INUM(x);
+ z = ((yy<0) ? -z : z)%yy;
+#else
+ z = INUM(x)%yy;
+#endif
+ return MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z);
+}
+
+SCM lgcd(x, y)
+ SCM x, y;
+{
+ register long u, v, k, t;
+ tailrec:
+ if UNBNDP(y) return UNBNDP(x) ? INUM0 : x;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ big_gcd:
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
+ if BIGSIGN(x) x = copybig(x, 0);
+ newy:
+ if NINUMP(y) {
+ ASSERT(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
+ if BIGSIGN(y) y = copybig(y, 0);
+ switch (bigcomp(x, y)) {
+ case -1:
+ swaprec: t = lremainder(x, y); x = y; y = t; goto tailrec;
+ case 0: return x;
+ case 1: y = lremainder(y, x); goto newy;
+ }
+ /* instead of the switch, we could just return lgcd(y, modulo(x, y)); */
+ }
+ if (INUM0==y) return x; goto swaprec;
+ }
+ if NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
+#else
+ ASSERT(INUMP(x), x, ARG1, s_gcd);
+ ASSERT(INUMP(y), y, ARG2, s_gcd);
+#endif
+ u = INUM(x);
+ if (u<0) u = -u;
+ v = INUM(y);
+ if (v<0) v = -v;
+ else if (0==v) goto getout;
+ if (0==u) {u = v; goto getout;}
+ for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1);
+ if (1 & (int)u) t = -v;
+ else {
+ t = u;
+b3:
+ t = SRS(t, 1);
+ }
+ if (!(1 & (int)t)) goto b3;
+ if (t>0) u = t;
+ else v = -t;
+ if ((t = u-v)) goto b3;
+ u = u*k;
+getout:
+ if (!POSFIXABLE(u))
+#ifdef BIGDIG
+ return long2big(u);
+#else
+ wta(x, (char *)OVFLOW, s_gcd);
+#endif
+ return MAKINUM(u);
+}
+SCM llcm(n1, n2)
+ SCM n1, n2;
+{
+ SCM d;
+ if UNBNDP(n2) {
+ n2 = MAKINUM(1L);
+ if UNBNDP(n1) return n2;
+ }
+ d = lgcd(n1, n2);
+ if (INUM0==d) return d;
+ return absval(product(n1, lquotient(n2, d)));
+}
+
+/* Emulating 2's complement bignums with sign magnitude arithmetic:
+
+ Logand:
+ X Y Result Method:
+ (len)
+ + + + x (map digit:logand X Y)
+ + - + x (map digit:logand X (lognot (+ -1 Y)))
+ - + + y (map digit:logand (lognot (+ -1 X)) Y)
+ - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
+
+ Logior:
+ X Y Result Method:
+
+ + + + (map digit:logior X Y)
+ + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
+ - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
+ - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
+
+ Logxor:
+ X Y Result Method:
+
+ + + + (map digit:logxor X Y)
+ + - - (+ 1 (map digit:logxor X (+ -1 Y)))
+ - + - (+ 1 (map digit:logxor (+ -1 X) Y))
+ - - + (map digit:logxor (+ -1 X) (+ -1 Y))
+
+ Logtest:
+ X Y Result
+
+ + + (any digit:logand X Y)
+ + - (any digit:logand X (lognot (+ -1 Y)))
+ - + (any digit:logand (lognot (+ -1 X)) Y)
+ - - #t
+
+*/
+
+#ifdef BIGDIG
+
+SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn));
+SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+
+SCM scm_copy_big_dec(b, sign)
+ SCM b;
+ int sign;
+{
+ long num = -1;
+ sizet nx = NUMDIGS(b);
+ sizet i = 0;
+ SCM ans = mkbig(nx, sign);
+ BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
+ if BIGSIGN(b) do {
+ num += src[i];
+ if (num < 0) {dst[i] = num + BIGRAD; num = -1;}
+ else {dst[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else
+ while (nx--) dst[nx] = src[nx];
+ return ans;
+}
+
+SCM scm_copy_smaller(x, nx, zsgn)
+ BIGDIG *x;
+ sizet nx;
+ int zsgn;
+{
+ long num = -1;
+ sizet i = 0;
+ SCM z = mkbig(nx, zsgn);
+ BIGDIG *zds = BDIGITS(z);
+ if (zsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = x[i]; while (++i < nx);
+ return z;
+}
+
+SCM scm_big_ior(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = scm_copy_big_dec(bigy, xsgn & BIGSIGN(bigy));
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn) {
+ do {
+ num += x[i];
+ if (num < 0) {zds[i] |= num + BIGRAD; num = -1;}
+ else {zds[i] |= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ /* ========= Need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return z;
+ }
+ adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */
+ BDIGITS(z)[ny] = 1;
+ return z;
+ }
+ else do zds[i] = zds[i] | x[i]; while (++i < nx);
+ return z;
+}
+
+SCM scm_big_xor(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = scm_copy_big_dec(bigy, xsgn ^ BIGSIGN(bigy));
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] ^= num + BIGRAD; num = -1;}
+ else {zds[i] ^= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do {
+ zds[i] = zds[i] ^ x[i];
+ } while (++i < nx);
+
+ if (xsgn ^ BIGSIGN(bigy)) {
+ /* ========= Need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return normbig(z);
+ }
+ }
+ return normbig(z);
+}
+
+SCM scm_big_and(x, nx, xsgn, bigy, zsgn)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+ int zsgn; /* return sign equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0;
+ SCM z;
+ BIGDIG *zds;
+ if (xsgn==zsgn) {
+ z = scm_copy_smaller(x, nx, zsgn);
+ x = BDIGITS(bigy);
+ xsgn = BIGSIGN(bigy);
+ }
+ else z = scm_copy_big_dec(bigy, zsgn);
+ zds = BDIGITS(z);
+
+ if (zsgn) {
+ if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
+ else {zds[i] &= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = zds[i] & ~x[i]; while (++i < nx);
+ /* ========= need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < nx) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return normbig(z);
+ }
+ }
+ else if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
+ else {zds[i] &= ~BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = zds[i] & x[i]; while (++i < nx);
+ return normbig(z);
+}
+
+SCM scm_big_test(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ BIGDIG *y;
+ sizet i = 0;
+ long num = -1;
+ if (BIGSIGN(bigy) & xsgn) return BOOL_T;
+ if (NUMDIGS(bigy) != nx && xsgn) return BOOL_T;
+ y = BDIGITS(bigy);
+ if (xsgn)
+ do {
+ num += x[i];
+ if (num < 0) {
+ if (y[i] & ~(num + BIGRAD)) return BOOL_T;
+ num = -1;
+ }
+ else {
+ if (y[i] & ~BIGLO(num)) return BOOL_T;
+ num = 0;
+ }
+ } while (++i < nx);
+ else if BIGSIGN(bigy)
+ do {
+ num += y[i];
+ if (num < 0) {
+ if (x[i] & ~(num + BIGRAD)) return BOOL_T;
+ num = -1;
+ }
+ else {
+ if (x[i] & ~BIGLO(num)) return BOOL_T;
+ num = 0;
+ }
+ } while (++i < nx);
+ else
+ do if (x[i] & y[i]) return BOOL_T;
+ while (++i < nx);
+ return BOOL_F;
+}
+
+#endif
+
+static char s_logand[] = "logand", s_lognot[] = "lognot",
+ s_logior[] = "logior", s_logxor[] = "logxor",
+ s_logtest[] = "logtest", s_logbitp[] = "logbit?",
+ s_ash[] = "ash", s_logcount[] = "logcount",
+ s_intlength[] = "integer-length",
+ s_intexpt[] = "integer-expt",
+ s_bitextract[] = "bit-extract";
+
+SCM scm_logior(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return INUM0;
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logior);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ if ((!BIGSIGN(x)) && !BIGSIGN(y))
+ return scm_big_ior(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logior);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ if ((!(x < 0)) && !BIGSIGN(y))
+ return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+ return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
+ 0x0100);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ if ((!(x < 0)) && !BIGSIGN(y))
+ return scm_big_ior(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+ return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logior);
+#endif
+ return MAKINUM(INUM(x) | INUM(y));
+}
+
+SCM scm_logand(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return MAKINUM(-1);
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logand);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ if ((BIGSIGN(x)) && BIGSIGN(y))
+ return scm_big_ior(BDIGITS(x), NUMDIGS(x), 0x0100, y);
+ return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logand);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ if ((x < 0) && BIGSIGN(y))
+ return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, 0x0100, y);
+ return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
+ 0);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ if ((x < 0) && BIGSIGN(y))
+ return scm_big_ior(zdigs, DIGSPERLONG, 0x0100, y);
+ return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logand);
+#endif
+ return MAKINUM(INUM(x) & INUM(y));
+}
+
+SCM scm_logxor(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return INUM0;
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logxor);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return scm_big_xor(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logxor);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return scm_big_xor((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return scm_big_xor(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logxor);
+#endif
+ return (x ^ y) + INUM0;
+}
+
+SCM scm_logtest(x, y)
+ SCM x, y;
+{
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logtest);
+#endif
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return scm_big_test(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logtest);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return scm_big_test((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return scm_big_test(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logtest);
+#endif
+ return (INUM(x) & INUM(y)) ? BOOL_T : BOOL_F;
+}
+
+SCM scm_logbitp(index, j1)
+ SCM index, j1;
+{
+ ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
+#ifdef BIGDIG
+ if NINUMP(j1) {
+ ASSERT(NIMP(j1) && BIGP(j1), j1, (char *)ARG2, s_logbitp);
+ if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
+ else if BIGSIGN(j1) {
+ long num = -1;
+ sizet i = 0;
+ BIGDIG *x = BDIGITS(j1);
+ sizet nx = INUM(index)/BITSPERDIG;
+ while (!0) {
+ num += x[i];
+ if (nx==i++)
+ return ((1L << (INUM(index)%BITSPERDIG)) & num) ? BOOL_F : BOOL_T;
+ if (num < 0) num = -1;
+ else num = 0;
+ }
+ }
+ else return (BDIGITS(j1)[INUM(index)/BITSPERDIG] &
+ (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F;
+ }
+#else
+ ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp);
+#endif
+ return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
+}
+
+SCM scm_lognot(n)
+ SCM n;
+{
+ return difference(MAKINUM(-1L), n);
+}
+
+SCM scm_intexpt(z1, z2)
+ SCM z1, z2;
+{
+ SCM acc = MAKINUM(1L);
+#ifdef BIGDIG
+ if (INUM0==z1 || acc==z1) return z1;
+ else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
+#endif
+ ASSERT(INUMP(z2), z2, ARG2, s_intexpt);
+ z2 = INUM(z2);
+ if (z2 < 0) {
+ z2 = -z2;
+ z1 = divide(z1, UNDEFINED);
+ }
+ while(1) {
+ if (0==z2) return acc;
+ if (1==z2) return product(acc, z1);
+ if (z2 & 1) acc = product(acc, z1);
+ z1 = product(z1, z1);
+ z2 >>= 1;
+ }
+}
+SCM scm_ash(n, cnt)
+ SCM n, cnt;
+{
+ SCM res = INUM(n);
+ ASSERT(INUMP(cnt), cnt, ARG2, s_ash);
+#ifdef BIGDIG
+ if(cnt < 0) {
+ res = scm_intexpt(MAKINUM(2), MAKINUM(-INUM(cnt)));
+ if NFALSEP(negativep(n))
+ return sum(MAKINUM(-1L), lquotient(sum(MAKINUM(1L), n), res));
+ else return lquotient(n, res);
+ }
+ else return product(n, scm_intexpt(MAKINUM(2), cnt));
+#else
+ ASSERT(INUMP(n), n, ARG1, s_ash);
+ cnt = INUM(cnt);
+ if (cnt < 0) return MAKINUM(SRS(res, -cnt));
+ res = MAKINUM(res<<cnt);
+ if (INUM(res)>>cnt != INUM(n)) wta(n, (char *)OVFLOW, s_ash);
+ return res;
+#endif
+}
+
+SCM scm_bitextract(n, start, end)
+ SCM n, start, end;
+{
+ ASSERT(INUMP(start), start, ARG2, s_bitextract);
+ ASSERT(INUMP(end), end, ARG3, s_bitextract);
+ start = INUM(start); end = INUM(end);
+ ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitextract);
+#ifdef BIGDIG
+ if NINUMP(n)
+ return
+ scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)),
+ MAKINUM(1L)),
+ scm_ash(n, MAKINUM(-start)));
+#else
+ ASSERT(INUMP(n), n, ARG1, s_bitextract);
+#endif
+ return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1));
+}
+
+char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
+SCM scm_logcount(n)
+ SCM n;
+{
+ register unsigned long c = 0;
+ register long nn;
+#ifdef BIGDIG
+ if NINUMP(n) {
+ sizet i; BIGDIG *ds, d;
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
+ if BIGSIGN(n) return scm_logcount(difference(MAKINUM(-1L), n));
+ ds = BDIGITS(n);
+ for(i = NUMDIGS(n); i--; )
+ for(d = ds[i]; d; d >>= 4) c += logtab[15 & d];
+ return MAKINUM(c);
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_logcount);
+#endif
+ if ((nn = INUM(n)) < 0) nn = -1 - nn;
+ for(; nn; nn >>= 4) c += logtab[15 & nn];
+ return MAKINUM(c);
+}
+
+char ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
+SCM scm_intlength(n)
+ SCM n;
+{
+ register unsigned long c = 0;
+ register long nn;
+ unsigned int l = 4;
+#ifdef BIGDIG
+ if NINUMP(n) {
+ BIGDIG *ds, d;
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
+ if BIGSIGN(n) return scm_intlength(difference(MAKINUM(-1L), n));
+ ds = BDIGITS(n);
+ d = ds[c = NUMDIGS(n)-1];
+ for(c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];}
+ return MAKINUM(c - 4 + l);
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_intlength);
+#endif
+ if ((nn = INUM(n)) < 0) nn = -1 - nn;
+ for(;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];}
+ return MAKINUM(c - 4 + l);
+}
+
+SCM charp(x)
+ SCM x;
+{
+ return ICHRP(x) ? BOOL_T : BOOL_F;
+}
+SCM char_lessp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_lessp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_lessp);
+ return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_leqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_leqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_leqp);
+ return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_grp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_grp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_grp);
+ return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_geqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_geqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_geqp);
+ return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM chci_eq(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_eq);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_eq);
+ return (upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_lessp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_lessp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_lessp);
+ return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_leqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_leqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_leqp);
+ return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_grp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_grp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_grp);
+ return (upcase[ICHR(x)] > upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_geqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_geqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_geqp);
+ return (upcase[ICHR(x)] >= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM char_alphap(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_alphap);
+ return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_nump(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_nump);
+ return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_whitep(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_whitep);
+ return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_upperp(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_upperp);
+ return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_lowerp(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_lowerp);
+ return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char2int(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_char2int);
+ return MAKINUM(ICHR(chr));
+}
+SCM int2char(n)
+ SCM n;
+{
+ ASSERT(INUMP(n), n, ARG1, s_int2char);
+ ASSERT((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
+ n, OUTOFRANGE, s_int2char);
+ return MAKICHR(INUM(n));
+}
+SCM char_upcase(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_upcase);
+ return MAKICHR(upcase[ICHR(chr)]);
+}
+SCM char_downcase(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_downcase);
+ return MAKICHR(downcase[ICHR(chr)]);
+}
+
+SCM stringp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return STRINGP(x) ? BOOL_T : BOOL_F;
+}
+SCM string(chrs)
+ SCM chrs;
+{
+ SCM res;
+ register char *data;
+ long i = ilength(chrs);
+ ASSERT(i >= 0, chrs, ARG1, s_string);
+ res = makstr(i);
+ data = CHARS(res);
+ for(;NNULLP(chrs);chrs = CDR(chrs)) {
+ ASSERT(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
+ *data++ = ICHR(CAR(chrs));
+ }
+ return res;
+}
+SCM make_string(k, chr)
+ SCM k, chr;
+{
+ SCM res;
+ register char *dst;
+ register long i;
+ ASSERT(INUMP(k) && (k >= 0), k, ARG1, s_make_string);
+ i = INUM(k);
+ res = makstr(i);
+ dst = CHARS(res);
+ if (!UNBNDP(chr)) {
+ ASSERT(ICHRP(chr), chr, ARG2, s_make_string);
+ for(i--;i >= 0;i--) dst[i] = ICHR(chr);
+ }
+ return res;
+}
+SCM st_length(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_length);
+ return MAKINUM(LENGTH(str));
+}
+SCM st_ref(str, k)
+ SCM str, k;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref);
+ ASSERT(INUMP(k), k, ARG2, s_st_ref);
+ ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref);
+ return MAKICHR(CHARS(str)[INUM(k)]);
+}
+SCM st_set(str, k, chr)
+ SCM str, k, chr;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_set);
+ ASSERT(INUMP(k), k, ARG2, s_st_set);
+ ASSERT(ICHRP(chr), chr, ARG3, s_st_set);
+ ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set);
+ CHARS(str)[INUM(k)] = ICHR(chr);
+ return UNSPECIFIED;
+}
+SCM st_equal(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i;
+ register char *c1, *c2;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal);
+ i = LENGTH(s2);
+ if (LENGTH(s1) != i) return BOOL_F;
+ c1 = CHARS(s1);
+ c2 = CHARS(s2);
+ while(0 != i--) if(*c1++ != *c2++) return BOOL_F;
+ return BOOL_T;
+}
+SCM stci_equal(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i;
+ register unsigned char *c1, *c2;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal);
+ i = LENGTH(s2);
+ if (LENGTH(s1) != i) return BOOL_F;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ while(0 != i--) if(upcase[*c1++] != upcase[*c2++]) return BOOL_F;
+ return BOOL_T;
+}
+SCM st_lessp(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i, len;
+ register unsigned char *c1, *c2;
+ register int c;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp);
+ len = LENGTH(s1);
+ i = LENGTH(s2);
+ if (len>i) i = len;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ for(i = 0;i<len;i++) {
+ c = (*c1++ - *c2++);
+ if (c>0) return BOOL_F;
+ if (c<0) return BOOL_T;
+ }
+ return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
+}
+SCM st_leqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(st_lessp(s2, s1));
+}
+SCM st_grp(s1, s2)
+ SCM s1, s2;
+{
+ return st_lessp(s2, s1);
+}
+SCM st_geqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(st_lessp(s1, s2));
+}
+SCM stci_lessp(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i, len;
+ register unsigned char *c1, *c2;
+ register int c;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp);
+ len = LENGTH(s1);
+ i = LENGTH(s2);
+ if (len>i) i=len;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ for(i = 0;i<len;i++) {
+ c = (upcase[*c1++] - upcase[*c2++]);
+ if (c>0) return BOOL_F;
+ if (c<0) return BOOL_T;
+ }
+ return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
+}
+SCM stci_leqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(stci_lessp(s2, s1));
+}
+SCM stci_grp(s1, s2)
+ SCM s1, s2;
+{
+ return stci_lessp(s2, s1);
+}
+SCM stci_geqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(stci_lessp(s1, s2));
+}
+SCM substring(str, start, end)
+ SCM str, start, end;
+{
+ long l;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_substring);
+ ASSERT(INUMP(start), start, ARG2, s_substring);
+ ASSERT(INUMP(end), end, ARG3, s_substring);
+ ASSERT(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring);
+ ASSERT(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring);
+ l = INUM(end)-INUM(start);
+ ASSERT(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring);
+ return makfromstr(&CHARS(str)[INUM(start)], (sizet)l);
+}
+SCM st_append(args)
+ SCM args;
+{
+ SCM res;
+ register long i = 0;
+ register SCM l, s;
+ register char *data;
+ for(l = args;NIMP(l);) {
+ ASSERT(CONSP(l), l, ARGn, s_st_append);
+ s = CAR(l);
+ ASSERT(NIMP(s) && STRINGP(s), s, ARGn, s_st_append);
+ i += LENGTH(s);
+ l = CDR(l);
+ }
+ ASSERT(NULLP(l), args, ARGn, s_st_append);
+ res = makstr(i);
+ data = CHARS(res);
+ for(l = args;NIMP(l);l = CDR(l)) {
+ s = CAR(l);
+ for(i = 0;i<LENGTH(s);i++) *data++ = CHARS(s)[i];
+ }
+ return res;
+}
+
+SCM vectorp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return VECTORP(x) ? BOOL_T : BOOL_F;
+}
+SCM vector_length(v)
+ SCM v;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
+ return MAKINUM(LENGTH(v));
+}
+SCM vector(l)
+ SCM l;
+{
+ SCM res;
+ register SCM *data;
+ long i = ilength(l);
+ ASSERT(i >= 0, l, ARG1, s_vector);
+ res = make_vector(MAKINUM(i), UNSPECIFIED);
+ data = VELTS(res);
+ for(;NIMP(l);l = CDR(l)) *data++ = CAR(l);
+ return res;
+}
+SCM vector_ref(v, k)
+ SCM v, k;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref);
+ ASSERT(INUMP(k), k, ARG2, s_ve_ref);
+ ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref);
+ return VELTS(v)[((long) INUM(k))];
+}
+SCM vector_set(v, k, obj)
+ SCM v, k, obj;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set);
+ ASSERT(INUMP(k), k, ARG2, s_ve_set);
+ ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set);
+ VELTS(v)[((long) INUM(k))] = obj;
+ return UNSPECIFIED;
+}
+char s_make_vector[] = "make-vector";
+SCM make_vector(k, fill)
+ SCM k, fill;
+{
+ SCM v;
+ register long i;
+ register SCM *velts;
+ ASSERT(INUMP(k), k, ARG1, s_make_vector);
+ if UNBNDP(fill) fill = UNSPECIFIED;
+ i = INUM(k);
+ NEWCELL(v);
+ DEFER_INTS;
+ SETCHARS(v, must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
+ SETLENGTH(v, i, tc7_vector);
+ velts = VELTS(v);
+ while(--i >= 0) (velts)[i] = fill;
+ ALLOW_INTS;
+ return v;
+}
+#ifdef BIGDIG
+char s_bignum[] = "bignum";
+SCM mkbig(nlen, sign)
+ sizet nlen;
+ int sign;
+{
+ SCM v = nlen;
+ if (((v << 16) >> 16) != nlen)
+ wta(MAKINUM(v), (char *)NALLOC, s_bignum);
+ NEWCELL(v);
+ DEFER_INTS;
+ SETCHARS(v, must_malloc((long)(nlen*sizeof(BIGDIG)), s_bignum));
+ SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
+ ALLOW_INTS;
+ return v;
+}
+SCM big2inum(b, l)
+ SCM b;
+ sizet l;
+{
+ unsigned long num = 0;
+ BIGDIG *tmp = BDIGITS(b);
+ while (l--) num = BIGUP(num) + tmp[l];
+ if (TYP16(b)==tc16_bigpos) {
+ if POSFIXABLE(num) return MAKINUM(num);
+ }
+ else if UNEGFIXABLE(num) return MAKINUM(-num);
+ return b;
+}
+char s_adjbig[] = "adjbig";
+SCM adjbig(b, nlen)
+ SCM b;
+ sizet nlen;
+{
+ long nsiz = nlen;
+ if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
+ DEFER_INTS;
+ SETCHARS(b, (BIGDIG *)must_realloc((char *)CHARS(b),
+ (long)(NUMDIGS(b)*sizeof(BIGDIG)),
+ (long)(nsiz*sizeof(BIGDIG)), s_adjbig));
+ SETNUMDIGS(b, nsiz, TYP16(b));
+ ALLOW_INTS;
+ return b;
+}
+SCM normbig(b)
+ SCM b;
+{
+# ifndef _UNICOS
+ sizet nlen = NUMDIGS(b);
+# else
+ int nlen = NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */
+# endif
+ BIGDIG *zds = BDIGITS(b);
+ while (nlen-- && !zds[nlen]); nlen++;
+ if (nlen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
+ if INUMP(b = big2inum(b, (sizet)nlen)) return b;
+ if (NUMDIGS(b)==nlen) return b;
+ return adjbig(b, (sizet)nlen);
+}
+SCM copybig(b, sign)
+ SCM b;
+ int sign;
+{
+ sizet i = NUMDIGS(b);
+ SCM ans = mkbig(i, sign);
+ BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
+ while (i--) dst[i] = src[i];
+ return ans;
+}
+SCM long2big(n)
+ long n;
+{
+ sizet i = 0;
+ BIGDIG *digits;
+ SCM ans = mkbig(DIGSPERLONG, n<0);
+ digits = BDIGITS(ans);
+ if (n < 0) n = -n;
+ while (i < DIGSPERLONG) {
+ digits[i++] = BIGLO(n);
+ n = BIGDN((unsigned long)n);
+ }
+ return ans;
+}
+SCM ulong2big(n)
+ unsigned long n;
+{
+ sizet i = 0;
+ BIGDIG *digits;
+ SCM ans = mkbig(DIGSPERLONG, 0);
+ digits = BDIGITS(ans);
+ while (i < DIGSPERLONG) {
+ digits[i++] = BIGLO(n);
+ n = BIGDN(n);
+ }
+ return ans;
+}
+
+int bigcomp(x, y)
+ SCM x, y;
+{
+ int xsign = BIGSIGN(x);
+ int ysign = BIGSIGN(y);
+ sizet xlen, ylen;
+ if (ysign < xsign) return 1;
+ if (ysign > xsign) return -1;
+ if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
+ if (ylen < xlen) return (xsign) ? 1 : -1;
+ while(xlen-- && (BDIGITS(y)[xlen]==BDIGITS(x)[xlen]));
+ if (-1==xlen) return 0;
+ return (BDIGITS(y)[xlen] > BDIGITS(x)[xlen]) ?
+ (xsign ? -1 : 1) : (xsign ? 1 : -1);
+}
+
+# ifndef DIGSTOOBIG
+long pseudolong(x)
+ long x;
+{
+ union {
+ long l;
+ BIGDIG bd[DIGSPERLONG];
+ } p;
+ sizet i = 0;
+ if (x < 0) x = -x;
+ while (i < DIGSPERLONG) {p.bd[i++] = BIGLO(x); x = BIGDN(x);}
+/* p.bd[0] = BIGLO(x); p.bd[1] = BIGDN(x); */
+ return p.l;
+}
+# else
+void longdigs(x, digs)
+ long x;
+ BIGDIG digs[DIGSPERLONG];
+{
+ sizet i = 0;
+ if (x < 0) x = -x;
+ while (i < DIGSPERLONG) {digs[i++] = BIGLO(x); x = BIGDN(x);}
+}
+# endif
+
+SCM addbig(x, nx, xsgn, bigy, sgny)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn, sgny; /* Assumes xsgn and sgny equal either 0 or 0x0100 */
+{
+ long num = 0;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = copybig(bigy, BIGSIGN(bigy) ^ sgny);
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn ^ BIGSIGN(z)) {
+ do {
+ num += (long) zds[i] - x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ if (num && nx==ny) {
+ num = 1; i = 0;
+ CAR(z) ^= 0x0100;
+ do {
+ num += (BIGRAD-1) - zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ } while (i < ny);
+ }
+ else while (i < ny) {
+ num += zds[i];
+ if (num < 0) {zds[i++] = num + BIGRAD; num = -1;}
+ else {zds[i++] = BIGLO(num); num = 0;}
+ }
+ } else {
+ do {
+ num += (long) zds[i] + x[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ } while (i < nx);
+ if (!num) return z;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return z;
+ }
+ if (num) {z = adjbig(z, ny+1); BDIGITS(z)[ny] = num; return z;}
+ }
+ return normbig(z);
+}
+
+SCM mulbig(x, nx, y, ny, sgn)
+ BIGDIG *x, *y;
+ sizet nx, ny;
+ int sgn;
+{
+ sizet i = 0, j = nx + ny;
+ unsigned long n = 0;
+ SCM z = mkbig(j, sgn);
+ BIGDIG *zds = BDIGITS(z);
+ while (j--) zds[j] = 0;
+ do {
+ j = 0;
+ if (x[i]) {
+ do {
+ n += zds[i + j] + ((unsigned long) x[i] * y[j]);
+ zds[i + j++] = BIGLO(n);
+ n = BIGDN(n);
+ } while (j < ny);
+ if (n) {zds[i + j] = n; n = 0;}
+ }
+ } while (++i < nx);
+ return normbig(z);
+}
+unsigned int divbigdig(ds, h, div)
+ BIGDIG *ds;
+ sizet h;
+ BIGDIG div;
+{
+ register unsigned long t2 = 0;
+ while(h--) {
+ t2 = BIGUP(t2) + ds[h];
+ ds[h] = t2 / div;
+ t2 %= div;
+ }
+ return t2;
+}
+SCM divbigint(x, z, sgn, mode)
+ SCM x;
+ long z;
+ int sgn, mode;
+{
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ register unsigned long t2 = 0;
+ register BIGDIG *ds = BDIGITS(x);
+ sizet nd = NUMDIGS(x);
+ while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z;
+ if (mode && t2) t2 = z - t2;
+ return MAKINUM(sgn ? -t2 : t2);
+ }
+ {
+# ifndef DIGSTOOBIG
+ unsigned long t2 = pseudolong(z);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&t2,
+ DIGSPERLONG, sgn, mode);
+# else
+ BIGDIG t2[DIGSPERLONG];
+ longdigs(z, t2);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), t2, DIGSPERLONG, sgn, mode);
+# endif
+ }
+}
+SCM divbigbig(x, nx, y, ny, sgn, modes)
+ BIGDIG *x, *y;
+ sizet nx, ny;
+ int sgn, modes;
+ /* modes description
+ 0 remainder
+ 1 modulo
+ 2 quotient
+ 3 quotient but returns 0 if division is not exact. */
+{
+ sizet i = 0, j = 0;
+ long num = 0;
+ unsigned long t2 = 0;
+ SCM z, newy;
+ BIGDIG d = 0, qhat, *zds, *yds;
+ /* algorithm requires nx >= ny */
+ if (nx < ny)
+ switch (modes) {
+ case 0: /* remainder -- just return x */
+ z = mkbig(nx, sgn); zds = BDIGITS(z);
+ do {zds[i] = x[i];} while (++i < nx);
+ return z;
+ case 1: /* modulo -- return y-x */
+ z = mkbig(ny, sgn); zds = BDIGITS(z);
+ do {
+ num += (long) y[i] - x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = num; num = 0;}
+ } while (++i < nx);
+ while (i < ny) {
+ num += y[i];
+ if (num < 0) {zds[i++] = num + BIGRAD; num = -1;}
+ else {zds[i++] = num; num = 0;}
+ }
+ goto doadj;
+ case 2: return INUM0; /* quotient is zero */
+ case 3: return 0; /* the division is not exact */
+ }
+
+ z = mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = BDIGITS(z);
+ if (nx==ny) zds[nx+1] = 0;
+ while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */
+ if (y[ny-1] < (BIGRAD>>1)) { /* normalize operands */
+ d = BIGRAD/(y[ny-1]+1);
+ newy = mkbig(ny, 0); yds = BDIGITS(newy);
+ while(j < ny)
+ {t2 += (unsigned long) y[j]*d; yds[j++] = BIGLO(t2); t2 = BIGDN(t2);}
+ y = yds; j = 0; t2 = 0;
+ while(j < nx)
+ {t2 += (unsigned long) x[j]*d; zds[j++] = BIGLO(t2); t2 = BIGDN(t2);}
+ zds[j] = t2;
+ }
+ else {zds[j = nx] = 0; while (j--) zds[j] = x[j];}
+ j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */
+ do { /* loop over digits of quotient */
+ if (zds[j]==y[ny-1]) qhat = BIGRAD-1;
+ else qhat = (BIGUP(zds[j]) + zds[j-1])/y[ny-1];
+ if (!qhat) continue;
+ i = 0; num = 0; t2 = 0;
+ do { /* multiply and subtract */
+ t2 += (unsigned long) y[i] * qhat;
+ num += zds[j - ny + i] - BIGLO(t2);
+ if (num < 0) {zds[j - ny + i] = num + BIGRAD; num = -1;}
+ else {zds[j - ny + i] = num; num = 0;}
+ t2 = BIGDN(t2);
+ } while (++i < ny);
+ num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
+ while (num) { /* "add back" required */
+ i = 0; num = 0; qhat--;
+ do {
+ num += (long) zds[j - ny + i] + y[i];
+ zds[j - ny + i] = BIGLO(num);
+ num = BIGDN(num);
+ } while (++i < ny);
+ num--;
+ }
+ if (modes & 2) zds[j] = qhat;
+ } while (--j >= ny);
+ switch (modes) {
+ case 3: /* check that remainder==0 */
+ for(j = ny;j && !zds[j-1];--j) ; if (j) return 0;
+ case 2: /* move quotient down in z */
+ j = (nx==ny ? nx+2 : nx+1) - ny;
+ for (i = 0;i < j;i++) zds[i] = zds[i+ny];
+ ny = i;
+ break;
+ case 1: /* subtract for modulo */
+ i = 0; num = 0; j = 0;
+ do {num += y[i] - zds[i];
+ j = j | zds[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = num; num = 0;}
+ } while (++i < ny);
+ if (!j) return INUM0;
+ case 0: /* just normalize remainder */
+ if (d) divbigdig(zds, ny, d);
+ }
+ doadj:
+ for(j = ny;j && !zds[j-1];--j) ;
+ if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT)
+ if INUMP(z = big2inum(z, j)) return z;
+ return adjbig(z, j);
+}
+#endif
+
+static iproc cxrs[] = {
+ {"car", 0}, {"cdr", 0},
+ {"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0},
+ {"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0},
+ {"cdaar", 0}, {"cdadr", 0}, {"cddar", 0}, {"cdddr", 0},
+ {"caaaar", 0}, {"caaadr", 0}, {"caadar", 0}, {"caaddr", 0},
+ {"cadaar", 0}, {"cadadr", 0}, {"caddar", 0}, {"cadddr", 0},
+ {"cdaaar", 0}, {"cdaadr", 0}, {"cdadar", 0}, {"cdaddr", 0},
+ {"cddaar", 0}, {"cddadr", 0}, {"cdddar", 0}, {"cddddr", 0},
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {"not", lnot},
+ {"boolean?", booleanp},
+ {"pair?", consp},
+ {"null?", nullp},
+ {"list?", listp},
+ {s_length, length},
+ {s_reverse, reverse},
+ {"symbol?", symbolp},
+ {s_symbol2string, symbol2string},
+ {s_str2symbol, string2symbol},
+ {s_exactp, exactp},
+ {s_oddp, oddp},
+ {s_evenp, evenp},
+ {s_abs, absval},
+ {s_lognot, scm_lognot},
+ {s_logcount, scm_logcount},
+ {s_intlength, scm_intlength},
+ {"char?", charp},
+ {s_ch_alphap, char_alphap},
+ {s_ch_nump, char_nump},
+ {s_ch_whitep, char_whitep},
+ {s_ch_upperp, char_upperp},
+ {s_ch_lowerp, char_lowerp},
+ {s_char2int, char2int},
+ {s_int2char, int2char},
+ {s_ch_upcase, char_upcase},
+ {s_ch_downcase, char_downcase},
+ {"string?", stringp},
+ {s_st_length, st_length},
+ {"vector?", vectorp},
+ {s_ve_length, vector_length},
+ {"procedure?", procedurep},
+ {0, 0}};
+
+static char s_acons[] = "acons";
+static iproc subr2s[] = {
+ {&s_acons[1], cons},
+ {s_setcar, setcar},
+ {s_setcdr, setcdr},
+ {s_list_ref, list_ref},
+ {s_memq, memq},
+ {s_member, member},
+ {s_assq, assq},
+ {s_assoc, assoc},
+ {s_quotient, lquotient},
+ {s_remainder, lremainder},
+ {s_modulo, modulo},
+ {s_logtest, scm_logtest},
+ {s_logbitp, scm_logbitp},
+ {s_ash, scm_ash},
+ {s_intexpt, scm_intexpt},
+ {s_st_ref, st_ref},
+ {"string<=?", st_leqp},
+ {"string-ci<=?", stci_leqp},
+ {s_ve_ref, vector_ref},
+ {0, 0}};
+
+static iproc lsubrs[] = {
+ {s_list, list},
+ {s_append, append},
+ {s_string, string},
+ {s_st_append, st_append},
+ {s_vector, vector},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_make_string, make_string},
+ {s_make_vector, make_vector},
+ {0, 0}};
+
+static iproc asubrs[] = {
+ {s_gcd, lgcd},
+ {"lcm", llcm},
+ {s_logand, scm_logand},
+ {s_logior, scm_logior},
+ {s_logxor, scm_logxor},
+ {0, 0}};
+
+static iproc rpsubrs[] = {
+ {"eq?", eq},
+ {"equal?", equal},
+ {"char=?", eq},
+ {s_ch_lessp, char_lessp},
+ {s_ci_eq, chci_eq},
+ {s_ci_lessp, chci_lessp},
+ {s_ch_leqp, char_leqp},
+ {s_ci_leqp, chci_leqp},
+ {s_ch_grp, char_grp},
+ {s_ci_grp, chci_grp},
+ {s_ch_geqp, char_geqp},
+ {s_ci_geqp, chci_geqp},
+
+ {s_st_equal, st_equal},
+ {s_stci_equal, stci_equal},
+ {s_st_lessp, st_lessp},
+ {s_stci_lessp, stci_lessp},
+ {"string>?", st_grp},
+ {"string-ci>?", stci_grp},
+ {"string>=?", st_geqp},
+ {"string-ci>=?", stci_geqp},
+ {0, 0}};
+
+static iproc subr3s[] = {
+ {s_bitextract, scm_bitextract},
+ {s_substring, substring},
+ {s_acons, acons},
+ {s_st_set, st_set},
+ {s_ve_set, vector_set},
+ {0, 0}};
+
+void init_iprocs(subra, type)
+ iproc *subra;
+ int type;
+{
+ for(;subra->string; subra++)
+ make_subr(subra->string,
+ type,
+ subra->cproc);
+}
+
+void init_subrs()
+{
+ init_iprocs(cxrs, tc7_cxr);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(rpsubrs, tc7_rpsubr);
+ init_iprocs(lsubrs, tc7_lsubr);
+ init_iprocs(asubrs, tc7_asubr);
+ init_iprocs(subr3s, tc7_subr_3);
+}
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 <ctype.h>
+
+#include "scm.h"
+#include "setjump.h"
+void igc P((char *what, STACKITEM *stackbase));
+
+/* ttyname() etc. should be defined in <unistd.h>. But unistd.h is
+ missing on many systems. */
+
+#ifndef STDC_HEADERS
+ char *ttyname P((int fd));
+ char *tmpnam P((char *s));
+ sizet fwrite ();
+# ifdef sun
+# ifndef __svr4__
+ int fputs P((char *s, FILE* stream));
+ int fputc P((char c, FILE* stream));
+ int fflush P((FILE* stream));
+# endif
+# endif
+ int fgetc P((FILE* stream));
+ int fclose P((FILE* stream));
+ int pclose P((FILE* stream));
+ int unlink P((const char *pathname));
+ char *mktemp P((char *template));
+#endif
+
+static void gc_sweep P((void));
+
+char s_nogrow[] = "could not grow", s_heap[] = "heap",
+ s_hplims[] = "hplims";
+static char s_input_portp[] = "input-port?",
+ s_output_portp[] = "output-port?";
+static char s_open_file[] = "open-file";
+char s_close_port[] = "close-port";
+
+#ifdef __IBMC__
+# include <io.h>
+# include <direct.h>
+# define ttyname(x) "CON:"
+#else
+# ifndef MSDOS
+# ifndef ultrix
+# ifndef vms
+# ifdef _DCC
+# include <ioctl.h>
+# define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
+# else
+# ifdef MWC
+# include <sys/io.h>
+# else
+# ifndef THINK_C
+# ifndef ARM_ULIB
+# include <sys/ioctl.h>
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+# endif
+#endif /* __IBMC__ */
+SCM i_setbuf0(port) /* should be called with DEFER_INTS active */
+ SCM port;
+{
+#ifndef NOSETBUF
+# ifndef MSDOS
+# ifdef FIONREAD
+# ifndef ultrix
+ SYSCALL(setbuf(STREAM(port), 0););
+# endif
+# endif
+# endif
+#endif
+ return UNSPECIFIED;
+}
+
+long mode_bits(modes)
+ char *modes;
+{
+ return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0)
+ | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0)
+ | (strchr(modes, '0') ? BUF0 : 0);
+}
+
+SCM open_file(filename, modes)
+ SCM filename, modes;
+{
+ register SCM port;
+ FILE *f;
+ ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
+ ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file);
+ NEWCELL(port);
+ DEFER_INTS;
+ SYSCALL(f = fopen(CHARS(filename), CHARS(modes)););
+ if (!f) port = BOOL_F;
+ else {
+ SETSTREAM(port, f);
+ if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes))))
+ i_setbuf0(port);
+ ALLOW_INTS;
+ }
+ return port;
+}
+
+SCM close_port(port)
+ SCM port;
+{
+ sizet i;
+ ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
+ if CLOSEDP(port) return UNSPECIFIED;
+ i = PTOBNUM(port);
+ DEFER_INTS;
+ if (ptobs[i].fclose) {
+ SYSCALL((ptobs[i].fclose)(STREAM(port)););
+ }
+ CAR(port) &= ~OPN;
+ ALLOW_INTS;
+ return UNSPECIFIED;
+}
+SCM input_portp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return INPORTP(x) ? BOOL_T : BOOL_F;
+}
+SCM output_portp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return OUTPORTP(x) ? BOOL_T : BOOL_F;
+}
+
+#if (__TURBOC__==1)
+# undef L_tmpnam /* Not supported in TURBOC V1.0 */
+#endif
+#ifdef GO32
+# undef L_tmpnam
+#endif
+#ifdef MWC
+# undef L_tmpnam
+#endif
+
+#ifdef L_tmpnam
+SCM ltmpnam()
+{
+ char name[L_tmpnam];
+ SYSCALL(tmpnam(name););
+ return makfrom0str(name);
+}
+#else
+/* TEMPTEMPLATE is used only if mktemp() is being used instead of
+ tmpnam(). */
+
+# ifdef AMIGA
+# define TEMPTEMPLATE "T:SchemeaaaXXXXXX";
+# else
+# ifdef vms
+# define TEMPTEMPLATE "sys$scratch:aaaXXXXXX";
+# else /* vms */
+# ifdef __MSDOS__
+# ifdef GO32
+# define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX";
+# else
+# define TEMPTEMPLATE "TMPaaaXXXXXX";
+# endif
+# else /* __MSDOS__ */
+# define TEMPTEMPLATE "/tmp/aaaXXXXXX";
+# endif /* __MSDOS__ */
+# endif /* vms */
+# endif /* AMIGA */
+
+char template[] = TEMPTEMPLATE;
+# define TEMPLEN (sizeof template/sizeof(char) - 1)
+SCM ltmpnam()
+{
+ SCM name;
+ int temppos = TEMPLEN-9;
+ name = makfromstr(template, (sizet)TEMPLEN);
+ DEFER_INTS;
+inclp:
+ template[temppos]++;
+ if (!isalpha(template[temppos])) {
+ template[temppos++] = 'a';
+ goto inclp;
+ }
+# ifndef AMIGA
+# ifndef __MSDOS__
+ SYSCALL(temppos = !*mktemp(CHARS(name)););
+ if (temppos) name = BOOL_F;
+# endif
+# endif
+ ALLOW_INTS;
+ return name;
+}
+#endif /* L_tmpnam */
+
+#ifdef M_SYSV
+# define remove unlink
+#endif
+static char s_del_fil[] = "delete-file";
+SCM del_fil(str)
+ SCM str;
+{
+ int ans;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
+#ifdef STDC_HEADERS
+ SYSCALL(ans = remove(CHARS(str)););
+#else
+ SYSCALL(ans = unlink(CHARS(str)););
+#endif
+ return ans ? BOOL_F : BOOL_T;
+}
+
+void prinport(exp, port, type)
+ SCM exp; SCM port; char *type;
+{
+ lputs("#<", port);
+ if CLOSEDP(exp) lputs("closed-", port);
+ else {
+ if (RDNG & CAR(exp)) lputs("input-", port);
+ if (WRTNG & CAR(exp)) lputs("output-", port);
+ }
+ lputs(type, port);
+ lputc(' ', port);
+#ifndef MSDOS
+# ifndef __EMX__
+# ifndef _DCC
+# ifndef AMIGA
+# ifndef THINK_C
+ if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
+ lputs(ttyname(fileno(STREAM(exp))), port);
+ else
+# endif
+# endif
+# endif
+# endif
+#endif
+ if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
+ else intprint(CDR(exp), 16, port);
+ lputc('>', port);
+}
+static int prinfport(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ prinport(exp, port, s_port_type);
+ return !0;
+}
+static int prinstpt(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ prinport(exp, port, s_string);
+ return !0;
+}
+static int prinsfpt(exp, port, writing)
+ SCM exp; SCM port; int writing;
+{
+ prinport(exp, port, "soft");
+ return !0;
+}
+
+static int stputc(c, p)
+ int c; SCM p;
+{
+ sizet ind = INUM(CAR(p));
+ if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1)));
+ CHARS(CDR(p))[ind] = c;
+ CAR(p) = MAKINUM(ind + 1);
+ return c;
+}
+sizet stwrite(str, siz, num, p)
+ sizet siz, num;
+ char *str; SCM p;
+{
+ sizet ind = INUM(CAR(p));
+ sizet len = siz * num;
+ char *dst;
+ if (ind + len >= LENGTH(CDR(p)))
+ resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1)));
+ dst = &(CHARS(CDR(p))[ind]);
+ while (len--) dst[len] = str[len];
+ CAR(p) = MAKINUM(ind + siz*num);
+ return num;
+}
+static int stputs(s, p)
+ char *s; SCM p;
+{
+ stwrite(s, 1, strlen(s), p);
+ return 0;
+}
+static int stgetc(p)
+ SCM p;
+{
+ sizet ind = INUM(CAR(p));
+ if (ind >= LENGTH(CDR(p))) return EOF;
+ CAR(p) = MAKINUM(ind + 1);
+ return CHARS(CDR(p))[ind];
+}
+int noop0(stream)
+ FILE *stream;
+{
+ return 0;
+}
+SCM mkstrport(pos, str, modes, caller)
+ SCM pos;
+ SCM str;
+ long modes;
+ char *caller;
+{
+ SCM z;
+ ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
+ ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
+ str = cons(pos, str);
+ NEWCELL(z);
+ DEFER_INTS;
+ SETCHARS(z, str);
+ CAR(z) = tc16_strport | modes;
+ ALLOW_INTS;
+ return z;
+}
+static char s_cwos[] = "call-with-output-string";
+static char s_cwis[] = "call-with-input-string";
+SCM cwos(proc)
+ SCM proc;
+{
+ SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED),
+ OPN | WRTNG,
+ s_cwos);
+ apply(proc, p, listofnull);
+ return resizuve(CDR(CDR(p)), CAR(CDR(p)));
+}
+SCM cwis(str, proc)
+ SCM str, proc;
+{
+ SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis);
+ return apply(proc, p, listofnull);
+}
+#ifdef vms
+sizet pwrite(ptr, size, nitems, port)
+ char *ptr;
+ sizet size, nitems;
+ FILE* port;
+{
+ sizet len = size * nitems;
+ sizet i = 0;
+ for(;i < len;i++) putc(ptr[i], port);
+ return len;
+}
+# define ffwrite pwrite
+#else
+# define ffwrite fwrite
+#endif
+
+static ptobfuns fptob = {
+ mark0,
+ fclose,
+ prinfport,
+ 0,
+ fputc,
+ fputs,
+ ffwrite,
+ fflush,
+ fgetc,
+ fclose};
+ptobfuns pipob = {
+ mark0,
+ 0, /* replaced by pclose in init_ioext() */
+ 0, /* replaced by prinpipe in init_ioext() */
+ 0,
+ fputc,
+ fputs,
+ ffwrite,
+ fflush,
+ fgetc,
+ 0}; /* replaced by pclose in init_ioext() */
+static ptobfuns stptob = {
+ markcdr,
+ noop0,
+ prinstpt,
+ 0,
+ stputc,
+ stputs,
+ stwrite,
+ noop0,
+ stgetc,
+ 0};
+
+ /* Soft ports */
+
+/* fputc, fwrite, fputs, and fclose are called within a
+ SYSCALL. So we need to set errno to 0 before returning. fflush
+ may be called within a SYSCALL. So we need to set errno to 0
+ before returning. */
+
+static int sfputc(c, p)
+ int c; SCM p;
+{
+ apply(VELTS(p)[0], MAKICHR(c), listofnull);
+ errno = 0;
+ return c;
+}
+sizet sfwrite(str, siz, num, p)
+ sizet siz, num;
+ char *str; SCM p;
+{
+ SCM sstr;
+ sstr = makfromstr(str, siz * num);
+ apply(VELTS(p)[1], sstr, listofnull);
+ errno = 0;
+ return num;
+}
+static int sfputs(s, p)
+ char *s; SCM p;
+{
+ sfwrite(s, 1, strlen(s), p);
+ return 0;
+}
+int sfflush(stream)
+ SCM stream;
+{
+ SCM f = VELTS(stream)[2];
+ if (BOOL_F==f) return 0;
+ f = apply(f, EOL, EOL);
+ errno = 0;
+ return BOOL_F==f ? EOF : 0;
+}
+static int sfgetc(p)
+ SCM p;
+{
+ SCM ans;
+ ans = apply(VELTS(p)[3], EOL, EOL);
+ errno = 0;
+ if (FALSEP(ans) || EOF_VAL==ans) return EOF;
+ ASSERT(ICHRP(ans), ans, ARG1, "getc");
+ return ICHR(ans);
+}
+static int sfclose(p)
+ SCM p;
+{
+ SCM f = VELTS(p)[4];
+ if (BOOL_F==f) return 0;
+ f = apply(f, EOL, EOL);
+ errno = 0;
+ return BOOL_F==f ? EOF : 0;
+}
+static char s_mksfpt[] = "make-soft-port";
+SCM mksfpt(pv, modes)
+ SCM pv, modes;
+{
+ SCM z;
+ ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt);
+ ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
+ NEWCELL(z);
+ DEFER_INTS;
+ CAR(z) = tc16_sfport | mode_bits(CHARS(modes));
+ SETSTREAM(z, pv);
+ ALLOW_INTS;
+ return z;
+}
+
+static ptobfuns sfptob = {
+ markcdr,
+ noop0,
+ prinsfpt,
+ 0,
+ sfputc,
+ sfputs,
+ sfwrite,
+ sfflush,
+ sfgetc,
+ sfclose};
+
+static smobfuns freecell = {
+ mark0,
+ free0,
+ 0,
+ 0};
+static smobfuns flob = {
+ mark0,
+ /*flofree*/0,
+ floprint,
+ floequal};
+static smobfuns bigob = {
+ mark0,
+ /*bigfree*/0,
+ bigprint,
+ bigequal};
+void (**finals)() = 0;
+sizet num_finals = 0;
+static char s_final[] = "final";
+
+void init_types()
+{
+ numptob = 0;
+ ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns));
+ /* These newptob calls must be done in this order */
+ /* tc16_fport = */ newptob(&fptob);
+ /* tc16_pipe = */ newptob(&pipob);
+ /* tc16_strport = */ newptob(&stptob);
+ /* tc16_sfport = */ newptob(&sfptob);
+ numsmob = 0;
+ smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
+ /* These newsmob calls must be done in this order */
+ newsmob(&freecell);
+ newsmob(&flob);
+ newsmob(&bigob);
+ newsmob(&bigob);
+ finals = (void(**)())malloc(2 * sizeof(finals[0]));
+ num_finals = 0;
+}
+
+void add_final(final)
+ void (* final)();
+{
+ DEFER_INTS;
+ finals = (void (**)()) must_realloc((char *)finals,
+ 1L*(num_finals)*sizeof(finals[0]),
+ (1L+num_finals)*sizeof(finals[0]),
+ s_final);
+ finals[num_finals++] = final;
+ ALLOW_INTS;
+ return;
+}
+
+char s_obunhash[] = "object-unhash";
+static iproc subr0s[] = {
+ {"gc", gc},
+ {"tmpnam", ltmpnam},
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {s_input_portp, input_portp},
+ {s_output_portp, output_portp},
+ {s_close_port, close_port},
+ {"eof-object?", eof_objectp},
+ {s_cwos, cwos},
+ {"object-hash", obhash},
+ {s_obunhash, obunhash},
+ {s_del_fil, del_fil},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_open_file, open_file},
+ {s_cwis, cwis},
+ {s_mksfpt, mksfpt},
+ {0, 0}};
+
+SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
+void init_io(){
+ make_subr("dynamic-wind", tc7_subr_3, dynwind);
+ init_iprocs(subr0s, tc7_subr_0);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+#ifndef CHEAP_CONTINUATIONS
+ add_feature("full-continuation");
+#endif
+}
+
+void grew_lim(nm)
+ long nm;
+{
+ ALLOW_INTS;
+ growth_mon(s_limit, nm, "bytes");
+ DEFER_INTS;
+}
+int expmem = 0;
+sizet hplim_ind = 0;
+long heap_size = 0;
+CELLPTR *hplims, heap_org;
+SCM freelist = EOL;
+long mtrigger;
+char *must_malloc(len, what)
+ long len;
+ char *what;
+{
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated+size;
+ if (len != size)
+malerr:
+ wta(MAKINUM(len), (char *)NALLOC, what);
+ if ((nm <= mtrigger)) {
+ SYSCALL(ptr = (char *)malloc(size););
+ if (NULL != ptr) {mallocated = nm; return ptr;}
+ }
+ igc(what, CONT(rootcont)->stkbse);
+ nm = mallocated+size;
+ if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before malloc */
+ SYSCALL(ptr = (char *)malloc(size););
+ if (NULL != ptr) {
+ mallocated = nm;
+ if (nm > mtrigger) mtrigger = nm + nm/2;
+ return ptr;}
+ goto malerr;
+}
+char *must_realloc(where, olen, len, what)
+ char *where;
+ long olen, len;
+ char *what;
+{
+ char *ptr;
+ sizet size = len;
+ long nm = mallocated+size-olen;
+ if (len != size)
+ralerr:
+ wta(MAKINUM(len), (char *)NALLOC, what);
+ if ((nm <= mtrigger)) {
+ SYSCALL(ptr = (char *)realloc(where, size););
+ if (NULL != ptr) {mallocated = nm; return ptr;}
+ }
+ igc(what, CONT(rootcont)->stkbse);
+ nm = mallocated+size-olen;
+ if (nm > mtrigger) grew_lim(nm+nm/2); /* must do before realloc */
+ SYSCALL(ptr = (char *)realloc(where, size););
+ if (NULL != ptr) {
+ mallocated = nm;
+ if (nm > mtrigger) mtrigger = nm + nm/2;
+ return ptr;}
+ goto ralerr;
+}
+void must_free(obj)
+ char *obj;
+{
+ if (obj) free(obj);
+ else wta(INUM0, "already free", "");
+}
+
+SCM symhash; /* This used to be a sys_protect, but
+ Radey Shouman <shouman@zianet.com>
+ added GC for unuesd, UNDEFINED
+ symbols.*/
+int symhash_dim = NUM_HASH_BUCKETS;
+/* sym2vcell looks up the symbol in the symhash table. */
+SCM sym2vcell(sym)
+ SCM sym;
+{
+ SCM lsym, z;
+ sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym),
+ (unsigned long)symhash_dim);
+ for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
+ z = CAR(lsym);
+ if (CAR(z)==sym) return z;
+ }
+ wta(sym, "uninterned symbol? ", "");
+}
+/* intern() and sysintern() return a pair;
+ CAR is the symbol, CDR is the value. */
+SCM intern(name, len)
+ char *name;
+ sizet len;
+{
+ SCM lsym, z;
+ register sizet i = len;
+ register unsigned char *tmp = (unsigned char *)name;
+ sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
+ for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
+ z = CAR(lsym);
+ z = CAR(z);
+ tmp = UCHARS(z);
+ if (LENGTH(z) != len) goto trynext;
+ for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
+ return CAR(lsym);
+ trynext: ;
+ }
+ lsym = makfromstr(name, len);
+ DEFER_INTS;
+ SETLENGTH(lsym, (long)len, tc7_msymbol);
+ ALLOW_INTS;
+ z = acons(lsym, UNDEFINED, UNDEFINED);
+ DEFER_INTS; /* Operations on symhash must be atomic. */
+ CDR(z) = VELTS(symhash)[hash];
+ VELTS(symhash)[hash] = z;
+ z = CAR(z);
+ ALLOW_INTS;
+ return z;
+}
+SCM sysintern(name, val)
+ char *name;
+ SCM val;
+{
+ SCM lsym, z;
+ sizet len = strlen(name);
+ register sizet i = len;
+ register unsigned char *tmp = (unsigned char *)name;
+ sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
+ for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
+ z = CAR(lsym);
+ z = CAR(z);
+ tmp = UCHARS(z);
+ if (LENGTH(z) != len) goto trynext;
+ for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
+ lsym = CAR(lsym);
+ CDR(lsym) = val;
+ return lsym;
+ trynext: ;
+ }
+ NEWCELL(lsym);
+ SETLENGTH(lsym, (long)len, tc7_ssymbol);
+ SETCHARS(lsym, name);
+ lsym = cons(lsym, val);
+ z = cons(lsym, UNDEFINED);
+ CDR(z) = VELTS(symhash)[hash];
+ VELTS(symhash)[hash] = z;
+ return lsym;
+}
+SCM cons(x, y)
+ SCM x, y;
+{
+ register SCM z;
+ NEWCELL(z);
+ CAR(z) = x;
+ CDR(z) = y;
+ return z;
+}
+SCM cons2(w, x, y)
+ SCM w, x, y;
+{
+ register SCM z;
+ NEWCELL(z);
+ CAR(z) = x;
+ CDR(z) = y;
+ x = z;
+ NEWCELL(z);
+ CAR(z) = w;
+ CDR(z) = x;
+ return z;
+}
+SCM acons(w, x, y)
+ SCM w, x, y;
+{
+ register SCM z;
+ NEWCELL(z);
+ CAR(z) = w;
+ CDR(z) = x;
+ x = z;
+ NEWCELL(z);
+ CAR(z) = x;
+ CDR(z) = y;
+ return z;
+}
+
+SCM makstr(len)
+ long len;
+{
+ SCM s;
+ NEWCELL(s);
+ DEFER_INTS;
+ SETCHARS(s, must_malloc(len+1, s_string));
+ SETLENGTH(s, len, tc7_string);
+ ALLOW_INTS;
+ CHARS(s)[len] = 0;
+ return s;
+}
+
+SCM make_subr(name, type, fcn)
+ char *name;
+ int type;
+ SCM (*fcn)();
+{
+ SCM symcell = sysintern(name, UNDEFINED);
+ long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
+ register SCM z;
+ if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
+ tmp = 0;
+ NEWCELL(z);
+ SUBRF(z) = fcn;
+ CAR(z) = tmp + type;
+ CDR(symcell) = z;
+ return z;
+}
+
+#ifdef CCLO
+SCM makcclo(proc, len)
+ SCM proc;
+ long len;
+{
+ SCM s;
+ NEWCELL(s);
+ DEFER_INTS;
+ SETCHARS(s, must_malloc(len*sizeof(SCM), "compiled-closure"));
+ SETLENGTH(s, len, tc7_cclo);
+ while (--len) VELTS(s)[len] = UNSPECIFIED;
+ CCLO_SUBR(s) = proc;
+ ALLOW_INTS;
+ return s;
+}
+#endif
+
+#ifdef STACK_LIMIT
+void stack_check()
+{
+ STACKITEM *start = CONT(rootcont)->stkbse;
+ STACKITEM stack;
+# ifdef STACK_GROWS_UP
+ if (&stack - start > STACK_LIMIT/sizeof(STACKITEM))
+# else
+ if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
+# endif /* def STACK_GROWS_UP */
+ wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
+}
+#endif
+void stack_report()
+{
+ STACKITEM stack;
+ intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 16, cur_errp);
+ lputs(" of stack: 0x", cur_errp);
+ intprint((long)CONT(rootcont)->stkbse, 16, cur_errp);
+ lputs(" - 0x", cur_errp);
+ intprint((long)&stack, 16, cur_errp);
+ lputs("\n", cur_errp);
+}
+
+SCM dynwind(thunk1, thunk2, thunk3)
+ SCM thunk1, thunk2, thunk3;
+{
+ SCM ans;
+ apply(thunk1, EOL, EOL);
+ dynwinds = acons(thunk1, thunk3, dynwinds);
+ ans = apply(thunk2, EOL, EOL);
+ dynwinds = CDR(dynwinds);
+ apply(thunk3, EOL, EOL);
+ return ans;
+}
+void dowinds(to, delta)
+ SCM to;
+ long delta;
+{
+ tail:
+ if (dynwinds==to);
+ else if (0 > delta) {
+ dowinds(CDR(to), 1+delta);
+ apply(CAR(CAR(to)), EOL, EOL);
+ dynwinds = to;
+ }
+ else {
+ SCM from = CDR(CAR(dynwinds));
+ dynwinds = CDR(dynwinds);
+ apply(from, EOL, EOL);
+ delta--; goto tail; /* dowinds(to, delta-1); */
+ }
+}
+
+/* Remember that setjmp needs to be called after scm_make_cont */
+
+SCM scm_make_cont()
+{
+ SCM cont;
+ CONTINUATION *ncont;
+ NEWCELL(cont);
+ DEFER_INTS;
+ ncont = make_continuation(CONT(rootcont));
+ if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
+ ncont->other.parent = rootcont;
+ SETCONT(cont, ncont);
+ SETLENGTH(cont, ncont->length, tc7_contin);
+ ncont->other.dynenv = dynwinds;
+#ifdef CAUTIOUS
+ CONT(cont)->other.stack_trace = stacktrace;
+#endif
+ ALLOW_INTS;
+ return cont;
+}
+static char s_sstale[] = "strangely stale";
+void scm_dynthrow(cont, val)
+ CONTINUATION *cont;
+ SCM val;
+{
+ if (cont->stkbse != CONT(rootcont)->stkbse)
+ wta(cont->other.dynenv, &s_sstale[10], s_cont);
+ dowinds(cont->other.dynenv,
+ ilength(dynwinds)-ilength(cont->other.dynenv));
+#ifdef CAUTIOUS
+ stacktrace = cont->other.stack_trace;
+#endif
+ throw_to_continuation(cont, val, CONT(rootcont));
+ wta(cont->other.dynenv, s_sstale, s_cont);
+}
+
+SCM obhash(obj)
+ SCM obj;
+{
+
+#ifdef BIGDIG
+ long n = SRS(obj, 1);
+ if (!FIXABLE(n)) return long2big(n);
+#endif
+ return (obj<<1)+2L;
+}
+
+SCM obunhash(obj)
+ SCM obj;
+{
+#ifdef BIGDIG
+ if (NIMP(obj) && BIGP(obj)) {
+ sizet i = NUMDIGS(obj);
+ BIGDIG *ds = BDIGITS(obj);
+ if (TYP16(obj)==tc16_bigpos) {
+ obj = 0;
+ while (i--) obj = BIGUP(obj) + ds[i];
+ }
+ else {
+ obj = 0;
+ while (i--) obj = BIGUP(obj) - ds[i];
+ }
+ obj <<= 1;
+ goto comm;
+ }
+#endif
+ ASSERT(INUMP(obj), obj, ARG1, s_obunhash);
+ obj = SRS(obj, 1) & ~1L;
+ comm:
+ if IMP(obj) return obj;
+ if NCELLP(obj) return BOOL_F;
+ { /* code is adapted from mark_locations */
+ register CELLPTR ptr = (CELLPTR)SCM2PTR(obj);
+ register sizet i = 0, j = hplim_ind;
+ do {
+ if PTR_GT(hplims[i++], ptr) break;
+ if PTR_LE(hplims[--j], ptr) break;
+ if ((i != j)
+ && PTR_LE(hplims[i++], ptr)
+ && PTR_GT(hplims[--j], ptr)) continue;
+ if NFREEP(obj) return obj;
+ break;
+ } while(i<j);
+ }
+ return BOOL_F;
+}
+
+unsigned long strhash(str, len, n)
+ unsigned char *str;
+ sizet len;
+ unsigned long n;
+{
+ if (len>5)
+ {
+ sizet i = 5;
+ unsigned long h = 264 % n;
+ while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n;
+ return h;
+ }
+ else {
+ sizet i = len;
+ unsigned long h = 0;
+ while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n;
+ return h;
+ }
+}
+
+static void fixconfig(s1, s2, s)
+ char *s1, *s2;
+ int s;
+{
+ fputs(s1, stderr);
+ fputs(s2, stderr);
+ fputs("\nin ", stderr);
+ fputs(s ? "setjump" : "scmfig", stderr);
+ fputs(".h and recompile scm\n", stderr);
+ quit(MAKINUM(1L));
+}
+
+sizet init_heap_seg(seg_org, size)
+ CELLPTR seg_org;
+ sizet size;
+{
+ register CELLPTR ptr = seg_org;
+#ifdef POINTERS_MUNGED
+ register SCM scmptr;
+#else
+# define scmptr ptr
+#endif
+ CELLPTR seg_end = CELL_DN((char *)ptr + size);
+ sizet i = hplim_ind, ni = 0;
+ if (ptr==NULL) return 0;
+ while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++;
+ while(i-- > ni) hplims[i+2] = hplims[i];
+ hplim_ind += 2;
+ hplims[ni++] = ptr; /* same as seg_org here */
+ hplims[ni++] = seg_end;
+ ptr = CELL_UP(ptr);
+ ni = seg_end - ptr;
+ for (i = ni;i--;ptr++) {
+#ifdef POINTERS_MUNGED
+ scmptr = PTR2SCM(ptr);
+#endif
+ CAR(scmptr) = (SCM)tc_free_cell;
+ CDR(scmptr) = PTR2SCM(ptr+1);
+ }
+/* CDR(scmptr) = freelist; */
+ CDR(PTR2SCM(--ptr)) = freelist;
+ freelist = PTR2SCM(CELL_UP(seg_org));
+ heap_size += ni;
+ return size;
+#ifdef scmptr
+# undef scmptr
+#endif
+}
+static void alloc_some_heap()
+{
+ CELLPTR ptr, *tmplims;
+ sizet len = (2+hplim_ind)*sizeof(CELLPTR);
+ ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
+ if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
+ SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len););
+ if (!tmplims)
+badhplims:
+ wta(UNDEFINED, s_nogrow, s_hplims);
+ else hplims = tmplims;
+ /* hplim_ind gets incremented in init_heap_seg() */
+ if (expmem) {
+ len = (sizet)(EXPHEAP(heap_size)*sizeof(cell));
+ if ((sizet)(EXPHEAP(heap_size)*sizeof(cell)) != len) len = 0;
+ }
+ else len = HEAP_SEG_SIZE;
+ while (len >= MIN_HEAP_SEG_SIZE) {
+ SYSCALL(ptr = (CELLPTR) malloc(len););
+ if (ptr) {
+ init_heap_seg(ptr, len);
+ return;
+ }
+ len /= 2;
+ }
+ wta(UNDEFINED, s_nogrow, s_heap);
+}
+
+smobfuns *smobs;
+sizet numsmob;
+long newsmob(smob)
+ smobfuns *smob;
+{
+ char *tmp;
+ if (255 <= numsmob) goto smoberr;
+ DEFER_INTS;
+ SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns)););
+ if (tmp) {
+ smobs = (smobfuns *)tmp;
+ smobs[numsmob].mark = smob->mark;
+ smobs[numsmob].free = smob->free;
+ smobs[numsmob].print = smob->print;
+ smobs[numsmob].equalp = smob->equalp;
+ numsmob++;
+ }
+ ALLOW_INTS;
+ if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob");
+ return tc7_smob + (numsmob-1)*256;
+}
+ptobfuns *ptobs;
+sizet numptob;
+long newptob(ptob)
+ ptobfuns *ptob;
+{
+ char *tmp;
+ if (255 <= numptob) goto ptoberr;
+ DEFER_INTS;
+ SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns)););
+ if (tmp) {
+ ptobs = (ptobfuns *)tmp;
+ ptobs[numptob].mark = ptob->mark;
+ ptobs[numptob].free = ptob->free;
+ ptobs[numptob].print = ptob->print;
+ ptobs[numptob].equalp = ptob->equalp;
+ ptobs[numptob].fputc = ptob->fputc;
+ ptobs[numptob].fputs = ptob->fputs;
+ ptobs[numptob].fwrite = ptob->fwrite;
+ ptobs[numptob].fflush = ptob->fflush;
+ ptobs[numptob].fgetc = ptob->fgetc;
+ ptobs[numptob].fclose = ptob->fclose;
+ numptob++;
+ }
+ ALLOW_INTS;
+ if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob");
+ return tc7_port + (numptob-1)*256;
+}
+SCM markcdr(ptr)
+ SCM ptr;
+{
+ if GC8MARKP(ptr) return BOOL_F;
+ SETGC8MARK(ptr);
+ return CDR(ptr);
+}
+SCM mark0(ptr)
+ SCM ptr;
+{
+ SETGC8MARK(ptr);
+ return BOOL_F;
+}
+sizet free0(ptr)
+ CELLPTR ptr;
+{
+ return 0;
+}
+SCM equal0(ptr1, ptr2)
+ SCM ptr1, ptr2;
+{
+ return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
+}
+
+/* statically allocated port for diagnostic messages */
+cell tmp_errp = {(SCM)((0L<<8)|tc16_fport|OPN|WRTNG), 0};
+
+static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
+extern sizet num_protects; /* sys_protects now in scl.c */
+void init_storage(stack_start_ptr, init_heap_size)
+ STACKITEM *stack_start_ptr;
+ long init_heap_size;
+{
+ sizet j = num_protects;
+ /* Because not all protects may get initialized */
+ while(j) sys_protects[--j] = BOOL_F;
+ tmp_errp.cdr = (SCM)stderr;
+ cur_errp = PTR2SCM(&tmp_errp);
+ freelist = EOL;
+ expmem = 0;
+
+#ifdef SHORT_INT
+ if (sizeof(int) >= sizeof(long))
+ fixconfig(remsg, "SHORT_INT", 1);
+#else
+ if (sizeof(int) < sizeof(long))
+ fixconfig(addmsg, "SHORT_INT", 1);
+#endif
+#ifdef CDR_DOUBLES
+ if (sizeof(double) != sizeof(long))
+ fixconfig(remsg, "CDR_DOUBLES", 0);
+#else
+# ifdef SINGLES
+ if (sizeof(float) != sizeof(long))
+ if (sizeof(double) == sizeof(long))
+ fixconfig(addmsg, "CDR_DOUBLES", 0);
+ else
+ fixconfig(remsg, "SINGLES", 0);
+# endif
+#endif
+#ifdef BIGDIG
+ if (2*BITSPERDIG/CHAR_BIT > sizeof(long))
+ fixconfig(remsg, "BIGDIG", 0);
+# ifndef DIGSTOOBIG
+ if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
+ fixconfig(addmsg, "DIGSTOOBIG", 0);
+# endif
+#endif
+#ifdef STACK_GROWS_UP
+ if (((STACKITEM *)&j - stack_start_ptr) < 0)
+ fixconfig(remsg, "STACK_GROWS_UP", 1);
+#else
+ if ((stack_start_ptr - (STACKITEM *)&j) < 0)
+ fixconfig(addmsg, "STACK_GROWS_UP", 1);
+#endif
+ j = HEAP_SEG_SIZE;
+ if (HEAP_SEG_SIZE != j)
+ fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
+
+ mtrigger = INIT_MALLOC_LIMIT;
+ hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
+ if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
+ j = init_heap_size;
+ if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
+ j = HEAP_SEG_SIZE;
+ if (!init_heap_seg((CELLPTR) malloc(j), j))
+ wta(MAKINUM(j), (char *)NALLOC, s_heap);
+ }
+ else expmem = 1;
+ heap_org = CELL_UP(hplims[0]);
+ /* hplims[0] can change. do not remove heap_org */
+
+ NEWCELL(def_inp);
+ CAR(def_inp) = (tc16_fport|OPN|RDNG);
+ SETSTREAM(def_inp, stdin);
+ NEWCELL(def_outp);
+ CAR(def_outp) = (tc16_fport|OPN|WRTNG);
+ SETSTREAM(def_outp, stdout);
+ NEWCELL(def_errp);
+ CAR(def_errp) = (tc16_fport|OPN|WRTNG);
+ SETSTREAM(def_errp, stderr);
+ cur_inp = def_inp;
+ cur_outp = def_outp;
+ cur_errp = def_errp;
+ dynwinds = EOL;
+ NEWCELL(rootcont);
+ SETCONT(rootcont, make_root_continuation(stack_start_ptr));
+ CAR(rootcont) = tc7_contin;
+ CONT(rootcont)->other.dynenv = EOL;
+ CONT(rootcont)->other.parent = BOOL_F;
+ stacktrace = EOL;
+#ifdef CAUTIOUS
+ CONT(rootcont)->other.stack_trace = EOL;
+#endif
+ listofnull = cons(EOL, EOL);
+ undefineds = cons(UNDEFINED, EOL);
+ CDR(undefineds) = undefineds;
+ nullstr = makstr(0L);
+ nullvect = make_vector(INUM0, UNDEFINED);
+ /* NEWCELL(nullvect);
+ CAR(nullvect) = tc7_vector;
+ SETCHARS(nullvect, NULL); */
+ symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL);
+ sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
+ sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
+#ifdef BIGDIG
+ sysintern("bignum-radix", MAKINUM(BIGRAD));
+#endif
+ /* flo0 is now setup in scl.c */
+}
+
+/* The way of garbage collecting which allows use of the cstack is due to */
+/* Scheme In One Defun, but in C this time.
+
+ * COPYRIGHT (c) 1989 BY *
+ * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
+ * ALL RIGHTS RESERVED *
+
+Permission to use, copy, modify, distribute and sell this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all copies
+and that both that copyright notice and this permission notice appear
+in supporting documentation, and that the name of Paradigm Associates
+Inc not be used in advertising or publicity pertaining to distribution
+of the software without specific, written prior permission.
+
+PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+SOFTWARE.
+
+gjc@paradigm.com
+
+Paradigm Associates Inc Phone: 617-492-6079
+29 Putnam Ave, Suite 6
+Cambridge, MA 02138
+*/
+char s_cells[] = "cells";
+SCM gc_for_newcell()
+{
+ SCM fl;
+ DEFER_INTS;
+ igc(s_cells, CONT(rootcont)->stkbse);
+ ALLOW_INTS;
+ if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
+ DEFER_INTS;
+ alloc_some_heap();
+ ALLOW_INTS;
+ growth_mon("number of heaps", (long)(hplim_ind/2), "segments");
+ growth_mon(s_heap, heap_size, s_cells);
+ }
+ ++cells_allocated;
+ fl = freelist;
+ freelist = CDR(fl);
+ return fl;
+}
+
+static char s_bad_type[] = "unknown type in ";
+jmp_buf save_regs_gc_mark;
+void mark_locations P((STACKITEM x[], sizet n));
+static void mark_syms P((SCM v));
+static void mark_sym_values P((SCM v));
+static void sweep_symhash P((SCM v));
+
+SCM gc()
+{
+ DEFER_INTS;
+ igc("call", CONT(rootcont)->stkbse);
+ ALLOW_INTS;
+ return UNSPECIFIED;
+}
+void igc(what, stackbase)
+ char *what;
+ STACKITEM *stackbase;
+{
+ int j = num_protects;
+ long oheap_size = heap_size;
+ gc_start(what);
+ ++errjmp_bad;
+ /* By marking symhash first, we provide the best immunity from
+ accidental references. In order to accidentally protect a
+ symbol, a pointer will have to point directly at the symbol (as
+ opposed to the vector or bucket lists). */
+ mark_syms(symhash);
+ /* mark_sym_values() can be called anytime after mark_syms. */
+#ifdef NO_SYM_GC
+ gc_mark(symhash);
+#else
+ mark_sym_values(symhash);
+#endif
+ if (stackbase) {
+ FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp(save_regs_gc_mark);
+ mark_locations((STACKITEM *) save_regs_gc_mark,
+ (sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) /
+ sizeof(STACKITEM));
+ {
+ /* stack_len is long rather than sizet in order to guarantee that
+ &stack_len is long aligned */
+#ifdef STACK_GROWS_UP
+# ifdef nosve
+ long stack_len = (STACKITEM *)(&stack_len) - stackbase;
+# else
+ long stack_len = stack_size(stackbase);
+# endif
+ mark_locations(stackbase, (sizet)stack_len);
+#else
+# ifdef nosve
+ long stack_len = stackbase - (STACKITEM *)(&stack_len);
+# else
+ long stack_len = stack_size(stackbase);
+# endif
+ mark_locations((stackbase - stack_len), (sizet)stack_len);
+#endif
+ }
+ }
+ while(j--) gc_mark(sys_protects[j]);
+ sweep_symhash(symhash);
+ gc_sweep();
+ --errjmp_bad;
+ gc_end();
+ if (oheap_size != heap_size) {
+ ALLOW_INTS;
+ growth_mon(s_heap, heap_size, s_cells);
+ DEFER_INTS;
+ }
+}
+
+static char s_not_free[] = "not freed";
+void free_storage()
+{
+ DEFER_INTS;
+ gc_start("free");
+ ++errjmp_bad;
+ cur_inp = BOOL_F; cur_outp = BOOL_F; cur_errp = PTR2SCM(&tmp_errp);
+ gc_mark(def_inp); /* don't want to close stdin */
+ gc_mark(def_outp); /* don't want to close stdout */
+ gc_mark(def_errp); /* don't want to close stderr */
+ gc_sweep();
+ rootcont = BOOL_F;
+ while (hplim_ind) { /* free heap segments */
+ hplim_ind -= 2;
+ {
+ CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
+ sizet seg_size = CELL_DN(hplims[hplim_ind+1]) - ptr;
+ heap_size -= seg_size;
+ must_free((char *)hplims[hplim_ind]);
+ hplims[hplim_ind] = 0;
+ growth_mon(s_heap, heap_size, s_cells);
+ }}
+ if (heap_size) wta(MAKINUM(heap_size), s_not_free, s_heap);
+ if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
+ /* Not all cells get freed (see gc_mark() calls above). */
+ /* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
+ /* either there is a small memory leak or I am counting wrong. */
+ /* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
+ must_free((char *)hplims);
+ hplims = 0;
+ must_free((char *)smobs);
+ smobs = 0;
+ gc_end();
+ ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
+ exit_report();
+ must_free((char *)ptobs);
+ ptobs = 0;
+ lmallocated = mallocated = 0;
+ /* Can't do gc_end() here because it uses ptobs which have been freed */
+}
+
+void gc_mark(p)
+ SCM p;
+{
+ register long i;
+ register SCM ptr = p;
+ gc_mark_loop:
+ if IMP(ptr) return;
+ gc_mark_nimp:
+ if (NCELLP(ptr)
+ /* #ifndef RECKLESS
+ || PTR_GT(hplims[0], (CELLPTR)ptr)
+ || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1])
+#endif */
+ ) wta(ptr, "rogue pointer in ", s_heap);
+ switch TYP7(ptr) {
+ case tcs_cons_nimcar:
+ if GCMARKP(ptr) break;
+ SETGCMARK(ptr);
+ if IMP(CDR(ptr)) { /* IMP works even with a GC mark */
+ ptr = CAR(ptr);
+ goto gc_mark_nimp;
+ }
+ gc_mark(CAR(ptr));
+ ptr = GCCDR(ptr);
+ goto gc_mark_nimp;
+ case tcs_cons_imcar:
+ case tcs_cons_gloc:
+ if GCMARKP(ptr) break;
+ SETGCMARK(ptr);
+ ptr = GCCDR(ptr);
+ goto gc_mark_loop;
+ case tcs_closures:
+ if GCMARKP(ptr) break;
+ SETGCMARK(ptr);
+ if IMP(CDR(ptr)) {
+ ptr = CODE(ptr);
+ goto gc_mark_nimp;
+ }
+ gc_mark(CODE(ptr));
+ ptr = GCCDR(ptr);
+ goto gc_mark_nimp;
+ case tc7_vector:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+ if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
+ i = LENGTH(ptr);
+ if (i==0) break;
+ while(--i>0) if NIMP(VELTS(ptr)[i]) gc_mark(VELTS(ptr)[i]);
+ ptr = VELTS(ptr)[0];
+ goto gc_mark_loop;
+ case tc7_contin:
+ if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
+ mark_locations((STACKITEM *)VELTS(ptr),
+ (sizet)(LENGTH(ptr) +
+ (sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
+ sizeof(STACKITEM)));
+ break;
+ case tc7_bvect:
+ case tc7_ivect:
+ case tc7_uvect:
+ case tc7_fvect:
+ case tc7_dvect:
+ case tc7_cvect:
+ case tc7_string:
+ case tc7_msymbol:
+ case tc7_ssymbol:
+ SETGC8MARK(ptr);
+ case tcs_subrs:
+ break;
+ case tc7_port:
+ i = PTOBNUM(ptr);
+ if (!(i < numptob)) goto def;
+ ptr = (ptobs[i].mark)(ptr);
+ goto gc_mark_loop;
+ case tc7_smob:
+ if GC8MARKP(ptr) break;
+ switch TYP16(ptr) { /* should be faster than going through smobs */
+ case tc_free_cell:
+ /* printf("found free_cell %X ", ptr); fflush(stdout); */
+ SETGC8MARK(ptr);
+ CDR(ptr) = EOL;
+ break;
+ case tcs_bignums:
+ case tc16_flo:
+ SETGC8MARK(ptr);
+ break;
+ default:
+ i = SMOBNUM(ptr);
+ if (!(i < numsmob)) goto def;
+ ptr = (smobs[i].mark)(ptr);
+ goto gc_mark_loop;
+ }
+ break;
+ default: def: wta(ptr, s_bad_type, "gc_mark");
+ }
+}
+
+void mark_locations(x, n)
+ STACKITEM x[];
+ sizet n;
+{
+ register long m = n;
+ register int i, j;
+ register CELLPTR ptr;
+ while(0 <= --m) if CELLP(*(SCM **)&x[m]) {
+ ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m]));
+ i = 0;
+ j = hplim_ind;
+ do {
+ if PTR_GT(hplims[i++], ptr) break;
+ if PTR_LE(hplims[--j], ptr) break;
+ if ((i != j)
+ && PTR_LE(hplims[i++], ptr)
+ && PTR_GT(hplims[--j], ptr)) continue;
+ /* if NFREEP(*(SCM **)&x[m]) */ gc_mark(*(SCM *)&x[m]);
+ break;
+ } while(i<j);
+ }
+}
+
+#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
+
+static void gc_sweep()
+{
+ register CELLPTR ptr;
+#ifdef POINTERS_MUNGED
+ register SCM scmptr;
+#else
+#define scmptr (SCM)ptr
+#endif
+ register SCM nfreelist = EOL;
+ register long n = 0, m = 0;
+ register sizet j;
+ sizet i = 0;
+ sizet seg_size;
+ while (i<hplim_ind) {
+ ptr = CELL_UP(hplims[i++]);
+ seg_size = CELL_DN(hplims[i++]) - ptr;
+ for(j = seg_size;j--;++ptr) {
+#ifdef POINTERS_MUNGED
+ scmptr = PTR2SCM(ptr);
+#endif
+ switch TYP7(scmptr) {
+ case tcs_cons_imcar:
+ case tcs_cons_nimcar:
+ case tcs_cons_gloc:
+ case tcs_closures:
+ if GCMARKP(scmptr) goto cmrkcontinue;
+ break;
+ case tc7_vector:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += (LENGTH(scmptr)*sizeof(SCM));
+ freechars:
+ must_free(CHARS(scmptr));
+/* SETCHARS(scmptr, 0);*/
+ break;
+ case tc7_bvect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += sizeof(long)*((HUGE_LENGTH(scmptr)+LONG_BIT-1)/LONG_BIT);
+ goto freechars;
+ case tc7_ivect:
+ case tc7_uvect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += HUGE_LENGTH(scmptr)*sizeof(long);
+ goto freechars;
+ case tc7_fvect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += HUGE_LENGTH(scmptr)*sizeof(float);
+ goto freechars;
+ case tc7_dvect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += HUGE_LENGTH(scmptr)*sizeof(double);
+ goto freechars;
+ case tc7_cvect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += HUGE_LENGTH(scmptr)*2*sizeof(double);
+ goto freechars;
+ case tc7_string:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += HUGE_LENGTH(scmptr)+1;
+ goto freechars;
+ case tc7_msymbol:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += LENGTH(scmptr)+1;
+ goto freechars;
+ case tc7_contin:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+/* free_continuation(CONT(scmptr)); */
+ goto freechars;
+ case tc7_ssymbol:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ /* Do not free storage because tc7_ssymbol means scmptr's
+ storage was not created by a call to malloc(). */
+ break;
+ case tcs_subrs:
+ continue;
+ case tc7_port:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ if OPENP(scmptr) {
+ int k = PTOBNUM(scmptr);
+ if (!(k < numptob)) goto sweeperr;
+ /* Yes, I really do mean ptobs[k].free */
+ /* rather than ftobs[k].close. .close */
+ /* is for explicit CLOSE-PORT by user */
+ (ptobs[k].free)(STREAM(scmptr));
+ gc_ports_collected++;
+ SETSTREAM(scmptr, 0);
+ CAR(scmptr) &= ~OPN;
+ }
+ break;
+ case tc7_smob:
+ switch GCTYP16(scmptr) {
+ case tc_free_cell:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ break;
+#ifdef BIGDIG
+ case tcs_bignums:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ m += (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+ goto freechars;
+#endif /* def BIGDIG */
+ case tc16_flo:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ switch ((int)(CAR(scmptr)>>16)) {
+ case (IMAG_PART | REAL_PART)>>16:
+ m += sizeof(double);
+ case REAL_PART>>16:
+ case IMAG_PART>>16:
+ m += sizeof(double);
+ goto freechars;
+ case 0:
+ break;
+ default:
+ goto sweeperr;
+ }
+ break;
+ default:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ {
+ int k = SMOBNUM(scmptr);
+ if (!(k < numsmob)) goto sweeperr;
+ m += (smobs[k].free)((CELLPTR)scmptr);
+ }
+ }
+ break;
+ default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep");
+ }
+ ++n;
+ CAR(scmptr) = (SCM)tc_free_cell;
+ CDR(scmptr) = nfreelist;
+ nfreelist = scmptr;
+ continue;
+ c8mrkcontinue:
+ CLRGC8MARK(scmptr);
+ continue;
+ cmrkcontinue:
+ CLRGCMARK(scmptr);
+ }
+#ifdef GC_FREE_SEGMENTS
+ if (n==seg_size) {
+ heap_size -= seg_size;
+ must_free((char *)hplims[i-2]);
+ hplims[i-2] = 0;
+ for(j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j];
+ hplim_ind -= 2;
+ i -= 2; /* need to scan segment just moved. */
+ nfreelist = freelist;
+ }
+ else
+#endif /* ifdef GC_FREE_SEGMENTS */
+ freelist = nfreelist;
+ gc_cells_collected += n;
+ n = 0;
+ }
+ lcells_allocated += (heap_size - gc_cells_collected - cells_allocated);
+ cells_allocated = (heap_size - gc_cells_collected);
+ lmallocated -= m;
+ mallocated -= m;
+ gc_malloc_collected = m;
+}
+
+/* mark_syms marks those symbols of hash table V which have
+ non-UNDEFINED values. */
+static char s_gc_sym[] = "mark_syms";
+static void mark_syms(v)
+ SCM v;
+{
+ SCM x, al;
+ int k = LENGTH(v);
+ while (k--)
+ for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
+ /* If this bucket has already been marked, then something is wrong. */
+ ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym);
+ x = CAR(al);
+ SETGCMARK(al);
+ ASSERT(!GCMARKP(x), x, s_bad_type, s_gc_sym);
+ if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
+ goto used; /* Don't mark symbol. */
+ SETGC8MARK(CAR(x));
+ used:
+ SETGCMARK(x); /* Do mark value cell. */
+ }
+ SETGC8MARK(v); /* Mark bucket list. */
+}
+
+/* mark_symhash marks the values of hash table V. */
+static void mark_sym_values(v)
+ SCM v;
+{
+ SCM x, al;
+ int k = LENGTH(v);
+ SETGC8MARK(v);
+ while (k--)
+ for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
+ x = GCCDR(CAR(al));
+ if IMP(x) continue;
+ gc_mark(x);
+ }
+}
+
+/* Splice any unused valueless symbols out of the hash buckets. */
+static void sweep_symhash(v)
+ SCM v;
+{
+ SCM al, x, *lloc;
+ int k = LENGTH(v);
+ while (k--) {
+ lloc = &(VELTS(v)[k]);
+ while NIMP(al = (*lloc & ~1L)) {
+ x = CAR(al);
+ if GC8MARKP(CAR(x))
+ lloc = &(CDR(al));
+ else {
+ *lloc = CDR(al);
+ CLRGCMARK(al); /* bucket pair to be collected by gc_sweep */
+ CLRGCMARK(x); /* value cell to be collected by gc_sweep */
+ gc_syms_collected++;
+ }
+ }
+ VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */
+ }
+}
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 <sys/types.h>
+# endif
+# ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+# else
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+# endif
+# endif
+# ifdef HAVE_SYS_TIMES_H
+# include <sys/times.h>
+# else
+# ifdef HAVE_SYS_TIMEB_H
+# include <sys/timeb.h>
+# endif
+# endif
+# ifdef HAVE_FTIME
+# ifdef unix
+# ifndef GO32
+# include <sys/timeb.h>
+# endif
+# endif
+# endif
+
+#else
+
+# ifdef STDC_HEADERS
+# include <time.h>
+# ifdef M_SYSV
+# include <sys/types.h>
+# include <sys/times.h>
+# endif
+# ifdef sun
+# include <sys/types.h>
+# include <sys/times.h>
+# endif
+# ifdef ultrix
+# include <sys/types.h>
+# include <sys/times.h>
+# endif
+# ifdef nosve
+# include <sys/types.h>
+# include <sys/times.h>
+# endif
+# ifdef _UNICOS
+# include <sys/types.h>
+# include <sys/times.h>
+# endif
+# ifdef __IBMC__
+# include <sys/timeb.h>
+# endif
+# else
+# ifdef SVR2
+# include <time.h>
+# else
+# ifndef ARM_ULIB
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+# endif
+# include <sys/types.h>
+
+# ifndef ARM_ULIB
+# include <sys/times.h>
+# else
+# include <time.h>
+# endif
+
+# endif
+
+/* Define this if your system lacks ftime(). */
+/* #define LACK_FTIME */
+/* Define this if your system lacks times(). */
+/* #define LACK_TIMES */
+
+# ifdef __TURBOC__
+# define LACK_TIMES
+# endif
+# if (__TURBOC__==1) /* Needed for TURBOC V1.0 */
+# define LACK_FTIME
+# undef MSDOS
+# endif
+# ifdef __HIGHC__
+# define LACK_TIMES
+# endif
+# ifdef THINK_C
+# define LACK_FTIME
+# define LACK_TIMES
+# define CLK_TCK 60
+# endif
+# ifdef SVR2
+# define LACK_FTIME
+# endif
+# ifdef SVR4
+# define LACK_FTIME
+# endif
+# ifdef __svr4__
+# define LACK_FTIME
+# endif
+# ifdef nosve
+# define LACK_FTIME
+# endif
+# ifdef GO32
+# define LACK_FTIME
+# define LACK_TIMES
+# endif
+# ifdef atarist
+# define LACK_FTIME
+# define LACK_TIMES
+# endif
+# ifdef ARM_ULIB
+# define LACK_FTIME
+# define LACK_TIMES
+# endif
+# ifdef _DCC
+# define LACK_FTIME
+# endif
+# ifdef MSDOS
+# ifndef GO32
+# include <sys/types.h>
+# include <sys/timeb.h>
+# endif
+# endif
+# ifdef _UNICOS
+# define LACK_FTIME
+# endif
+
+# ifndef LACK_FTIME
+# ifdef unix
+# ifndef GO32
+# include <sys/timeb.h>
+# endif
+# endif
+# endif
+
+# ifdef __EMX__
+# define LACK_TIMES
+# include <sys/types.h>
+# include <sys/timeb.h>
+# endif
+
+# ifdef MWC
+# include <time.h>
+# include <sys/timeb.h>
+# endif
+
+# ifdef ARM_ULIB
+# include <sys/types.h>
+# include <time.h>
+# endif
+
+#endif /* HAVE_CONFIG_H */
+
+#ifdef vms
+# define LACK_TIMES
+# define LACK_FTIME
+#endif
+
+#ifdef CLK_TCK
+# define CLKTCK CLK_TCK
+# ifdef CLOCKS_PER_SEC
+# ifdef unix
+# ifndef ARM_ULIB
+# include <sys/times.h>
+# endif
+# define LACK_CLOCK
+ /* This is because clock() might be POSIX rather than ANSI.
+ This occurs on HP-UX machines */
+# endif
+# endif
+#else
+# ifdef CLOCKS_PER_SEC
+# define CLKTCK CLOCKS_PER_SEC
+# else
+# define LACK_CLOCK
+# ifdef AMIGA
+# include <stddef.h>
+# define LACK_TIMES
+# define LACK_FTIME
+# define CLKTCK 1000
+# else
+# define CLKTCK 60
+# endif
+# endif
+#endif
+
+#ifdef __STDC__
+# define timet time_t
+#else
+# define timet long
+#endif
+
+#ifdef LACK_TIMES
+# ifdef LACK_CLOCK
+# ifdef AMIGA
+/* From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> */
+# ifdef AZTEC_C /* AZTEC_C */
+# include <devices/timer.h>
+static long mytime()
+{
+ long sec, mic, mili = 0;
+ struct timerequest *timermsg;
+ struct MsgPort *timerport;
+ if(!(timerport = (struct MsgPort *)CreatePort(0, 0))){
+ lputs("No mem for port.\n", cur_errp);
+ return mili;
+ }
+ if(!(timermsg = (struct timerequest *)
+ CreateExtIO(timerport, sizeof(struct timerequest)))){
+ lputs("No mem for timerequest.\n", cur_errp);
+ DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort);
+ return mili;
+ }
+ if(!(OpenDevice(TIMERNAME, UNIT_MICROHZ, timermsg, 0))){
+ timermsg->tr_node.io_Command = TR_GETSYSTIME;
+ timermsg->tr_node.io_Flags = 0;
+ DoIO(timermsg);
+ sec = timermsg->tr_time.tv_secs;
+ mic = timermsg->tr_time.tv_micro;
+ mili = sec*1000+mic/1000;
+ CloseDevice(timermsg);
+ }
+ else lputs("No Timer available.\n", cur_errp);
+ DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort);
+ DeleteExtIO(timermsg);
+ return mili ;
+}
+# else /* this is for SAS/C */
+static long mytime()
+{
+ unsigned int cl[2];
+ timer(cl);
+ return(cl[0]*1000+cl[1]/1000);
+}
+# endif /* AZTEC_C */
+# else /* AMIGA */
+# define mytime() ((time((timet*)0) - your_base) * CLKTCK)
+# endif /* AMIGA */
+# else /* LACK_CLOCK */
+# define mytime clock
+# endif /* LACK_CLOCK */
+#else /* LACK_TIMES */
+static long mytime()
+{
+ struct tms time_buffer;
+ times(&time_buffer);
+ return time_buffer.tms_utime + time_buffer.tms_stime;
+}
+#endif /* LACK_TIMES */
+
+#ifdef LACK_FTIME
+# ifdef AMIGA
+SCM your_time()
+{
+ return MAKINUM(mytime());
+}
+# else
+timet your_base = 0;
+SCM your_time()
+{
+ return MAKINUM((time((timet*)0) - your_base) * (int)CLKTCK);
+}
+# endif /* AMIGA */
+#else /* LACK_FTIME */
+struct timeb your_base = {0};
+SCM your_time()
+{
+ struct timeb time_buffer;
+ long tmp;
+ ftime(&time_buffer);
+ time_buffer.time -= your_base.time;
+ tmp = time_buffer.millitm - your_base.millitm;
+ tmp = time_buffer.time*1000L + tmp;
+ tmp *= CLKTCK;
+ tmp /= 1000;
+ return MAKINUM(tmp);
+}
+#endif /* LACK_FTIME */
+
+long my_base = 0;
+SCM my_time()
+{
+ return MAKINUM(mytime()-my_base);
+}
+
+SCM curtime()
+{
+ timet timv = time((timet*)0);
+ SCM ans;
+#ifndef _DCC
+# ifdef STDC_HEADERS
+# if (__TURBOC__ > 0x201)
+ timv = mktime(gmtime(&timv));
+# endif
+# endif
+#endif
+ ans = ulong2num(timv);
+ return BOOL_F==ans ? MAKINUM(timv) : ans;
+}
+
+long time_in_msec(x)
+ long x;
+{
+ if (CLKTCK==60) return (x*50)/3;
+ else
+ return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
+}
+
+static iproc subr0s[] = {
+ {"get-internal-run-time", my_time},
+ {"get-internal-real-time", your_time},
+ {"current-time", curtime},
+ {0, 0}};
+
+void init_time()
+{
+ sysintern("internal-time-units-per-second",
+ MAKINUM((long)CLKTCK));
+#ifdef LACK_FTIME
+# ifndef AMIGA
+ if (!your_base) time(&your_base);
+# endif
+#else
+ if (!your_base.time) ftime(&your_base);
+#endif
+ if (!my_base) my_base = mytime();
+ init_iprocs(subr0s, tc7_subr_0);
+}
diff --git a/unexec.c b/unexec.c
new file mode 100644
index 0000000..f7ff9ca
--- /dev/null
+++ b/unexec.c
@@ -0,0 +1,1238 @@
+/* Copyright (C) 1985,86,87,88,92,93,94 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+/*
+ * unexec.c - Convert a running program into an a.out file.
+ *
+ * Author: Spencer W. Thomas
+ * Computer Science Dept.
+ * University of Utah
+ * Date: Tue Mar 2 1982
+ * Modified heavily since then.
+ *
+ * Synopsis:
+ * unexec (new_name, a_name, data_start, bss_start, entry_address)
+ * char *new_name, *a_name;
+ * unsigned data_start, bss_start, entry_address;
+ *
+ * Takes a snapshot of the program and makes an a.out format file in the
+ * file named by the string argument new_name.
+ * If a_name is non-NULL, the symbol table will be taken from the given file.
+ * On some machines, an existing a_name file is required.
+ *
+ * The boundaries within the a.out file may be adjusted with the data_start
+ * and bss_start arguments. Either or both may be given as 0 for defaults.
+ *
+ * Data_start gives the boundary between the text segment and the data
+ * segment of the program. The text segment can contain shared, read-only
+ * program code and literal data, while the data segment is always unshared
+ * and unprotected. Data_start gives the lowest unprotected address.
+ * The value you specify may be rounded down to a suitable boundary
+ * as required by the machine you are using.
+ *
+ * Specifying zero for data_start means the boundary between text and data
+ * should not be the same as when the program was loaded.
+ * If NO_REMAP is defined, the argument data_start is ignored and the
+ * segment boundaries are never changed.
+ *
+ * Bss_start indicates how much of the data segment is to be saved in the
+ * a.out file and restored when the program is executed. It gives the lowest
+ * unsaved address, and is rounded up to a page boundary. The default when 0
+ * is given assumes that the entire data segment is to be stored, including
+ * the previous data and bss as well as any additional storage allocated with
+ * break (2).
+ *
+ * The new file is set up to start at entry_address.
+ *
+ * If you make improvements I'd like to get them too.
+ * harpo!utah-cs!thomas, thomas@Utah-20
+ *
+ */
+
+/* Modified to support SysVr3 shared libraries by James Van Artsdalen
+ * of Dell Computer Corporation. james@bigtex.cactus.org.
+ */
+
+/* There are several compilation parameters affecting unexec:
+
+* COFF
+
+Define this if your system uses COFF for executables.
+
+* COFF_ENCAPSULATE
+
+Define this if you are using the GNU coff encapsulated a.out format.
+This is closer to a.out than COFF. You should *not* define COFF if
+you define COFF_ENCAPSULATE
+
+Otherwise we assume you use Berkeley format.
+
+* NO_REMAP
+
+Define this if you do not want to try to save Emacs's pure data areas
+as part of the text segment.
+
+Saving them as text is good because it allows users to share more.
+
+However, on machines that locate the text area far from the data area,
+the boundary cannot feasibly be moved. Such machines require
+NO_REMAP.
+
+Also, remapping can cause trouble with the built-in startup routine
+/lib/crt0.o, which defines `environ' as an initialized variable.
+Dumping `environ' as pure does not work! So, to use remapping,
+you must write a startup routine for your machine in Emacs's crt0.c.
+If NO_REMAP is defined, Emacs uses the system's crt0.o.
+
+* SECTION_ALIGNMENT
+
+Some machines that use COFF executables require that each section
+start on a certain boundary *in the COFF file*. Such machines should
+define SECTION_ALIGNMENT to a mask of the low-order bits that must be
+zero on such a boundary. This mask is used to control padding between
+segments in the COFF file.
+
+If SECTION_ALIGNMENT is not defined, the segments are written
+consecutively with no attempt at alignment. This is right for
+unmodified system V.
+
+* SEGMENT_MASK
+
+Some machines require that the beginnings and ends of segments
+*in core* be on certain boundaries. For most machines, a page
+boundary is sufficient. That is the default. When a larger
+boundary is needed, define SEGMENT_MASK to a mask of
+the bits that must be zero on such a boundary.
+
+* A_TEXT_OFFSET(HDR)
+
+Some machines count the a.out header as part of the size of the text
+segment (a_text); they may actually load the header into core as the
+first data in the text segment. Some have additional padding between
+the header and the real text of the program that is counted in a_text.
+
+For these machines, define A_TEXT_OFFSET(HDR) to examine the header
+structure HDR and return the number of bytes to add to `a_text'
+before writing it (above and beyond the number of bytes of actual
+program text). HDR's standard fields are already correct, except that
+this adjustment to the `a_text' field has not yet been made;
+thus, the amount of offset can depend on the data in the file.
+
+* A_TEXT_SEEK(HDR)
+
+If defined, this macro specifies the number of bytes to seek into the
+a.out file before starting to write the text segment.
+
+* EXEC_MAGIC
+
+For machines using COFF, this macro, if defined, is a value stored
+into the magic number field of the output file.
+
+* ADJUST_EXEC_HEADER
+
+This macro can be used to generate statements to adjust or
+initialize nonstandard fields in the file header
+
+* ADDR_CORRECT(ADDR)
+
+Macro to correct an int which is the bit pattern of a pointer to a byte
+into an int which is the number of a byte.
+
+This macro has a default definition which is usually right.
+This default definition is a no-op on most machines (where a
+pointer looks like an int) but not on all machines.
+
+*/
+
+#ifndef emacs
+#define PERROR(arg) perror (arg); return -1
+#else
+#define IN_UNEXEC
+#include <config.h>
+#define PERROR(file) report_error (file, new)
+#endif
+
+#ifndef CANNOT_DUMP /* all rest of file! */
+
+#ifdef COFF_ENCAPSULATE
+int need_coff_header = 1;
+#include <coff-encap/a.out.encap.h> /* The location might be a poor assumption */
+#else
+#ifdef MSDOS
+#if __DJGPP__ > 1
+#include <fcntl.h> /* for O_RDONLY, O_RDWR */
+#include <crt0.h> /* for _crt0_startup_flags and its bits */
+static int save_djgpp_startup_flags;
+#endif
+#include <coff.h>
+#define filehdr external_filehdr
+#define scnhdr external_scnhdr
+#define syment external_syment
+#define auxent external_auxent
+#define n_numaux e_numaux
+#define n_type e_type
+struct aouthdr
+{
+ unsigned short magic; /* type of file */
+ unsigned short vstamp; /* version stamp */
+ unsigned long tsize; /* text size in bytes, padded to FW bdry*/
+ unsigned long dsize; /* initialized data " " */
+ unsigned long bsize; /* uninitialized data " " */
+ unsigned long entry; /* entry pt. */
+ unsigned long text_start;/* base of text used for this file */
+ unsigned long data_start;/* base of data used for this file */
+};
+
+
+#else /* not MSDOS */
+#include <a.out.h>
+#endif /* not MSDOS */
+#endif
+
+/* Define getpagesize if the system does not.
+ Note that this may depend on symbols defined in a.out.h. */
+#include "getpagesize.h"
+
+#ifndef makedev /* Try to detect types.h already loaded */
+#include <sys/types.h>
+#endif /* makedev */
+#include <stdio.h>
+#include <sys/stat.h>
+#include <errno.h>
+
+#include <sys/file.h> /* Must be after sys/types.h for USG and BSD4_1*/
+
+#ifdef USG5
+#include <fcntl.h>
+#endif
+
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#endif
+#ifndef O_RDWR
+#define O_RDWR 2
+#endif
+
+
+extern char *start_of_text (); /* Start of text */
+extern char *start_of_data (); /* Start of initialized data */
+
+#ifdef COFF
+static long block_copy_start; /* Old executable start point */
+static struct filehdr f_hdr; /* File header */
+static struct aouthdr f_ohdr; /* Optional file header (a.out) */
+long bias; /* Bias to add for growth */
+long lnnoptr; /* Pointer to line-number info within file */
+#define SYMS_START block_copy_start
+
+static long text_scnptr;
+static long data_scnptr;
+
+#else /* not COFF */
+
+#ifdef HPUX
+extern void *sbrk ();
+#else
+#if 0
+/* Some systems with __STDC__ compilers still declare this `char *' in some
+ header file, and our declaration conflicts. The return value is always
+ cast, so it should be harmless to leave it undefined. Hopefully
+ machines with different size pointers and ints declare sbrk in a header
+ file. */
+#ifdef __STDC__
+extern void *sbrk ();
+#else
+extern char *sbrk ();
+#endif /* __STDC__ */
+#endif
+#endif /* HPUX */
+
+#define SYMS_START ((long) N_SYMOFF (ohdr))
+
+/* Some machines override the structure name for an a.out header. */
+#ifndef EXEC_HDR_TYPE
+#define EXEC_HDR_TYPE struct exec
+#endif
+
+#ifdef HPUX
+#ifdef HP9000S200_ID
+#define MY_ID HP9000S200_ID
+#else
+#include <model.h>
+#define MY_ID MYSYS
+#endif /* no HP9000S200_ID */
+static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC};
+static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC};
+#define N_TXTOFF(x) TEXT_OFFSET(x)
+#define N_SYMOFF(x) LESYM_OFFSET(x)
+static EXEC_HDR_TYPE hdr, ohdr;
+
+#else /* not HPUX */
+
+#if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX)
+static struct bhdr hdr, ohdr;
+#define a_magic fmagic
+#define a_text tsize
+#define a_data dsize
+#define a_bss bsize
+#define a_syms ssize
+#define a_trsize rtsize
+#define a_drsize rdsize
+#define a_entry entry
+#define N_BADMAG(x) \
+ (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\
+ ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC)
+#define NEWMAGIC FMAGIC
+#else /* IRIS or IBMAIX or not USG */
+static EXEC_HDR_TYPE hdr, ohdr;
+#define NEWMAGIC ZMAGIC
+#endif /* IRIS or IBMAIX not USG */
+#endif /* not HPUX */
+
+static int unexec_text_start;
+static int unexec_data_start;
+
+#ifdef COFF_ENCAPSULATE
+/* coffheader is defined in the GNU a.out.encap.h file. */
+struct coffheader coffheader;
+#endif
+
+#endif /* not COFF */
+
+static int pagemask;
+
+/* Correct an int which is the bit pattern of a pointer to a byte
+ into an int which is the number of a byte.
+ This is a no-op on ordinary machines, but not on all. */
+
+#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */
+#define ADDR_CORRECT(x) ((char *)(x) - (char*)0)
+#endif
+
+#ifdef emacs
+
+#include "lisp.h"
+
+static
+report_error (file, fd)
+ char *file;
+ int fd;
+{
+ if (fd)
+ close (fd);
+ report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil));
+}
+#endif /* emacs */
+
+#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
+#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
+#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
+
+static
+report_error_1 (fd, msg, a1, a2)
+ int fd;
+ char *msg;
+ int a1, a2;
+{
+ close (fd);
+#ifdef emacs
+ error (msg, a1, a2);
+#else
+ fprintf (stderr, msg, a1, a2);
+ fprintf (stderr, "\n");
+#endif
+}
+
+static int make_hdr ();
+static int copy_text_and_data ();
+static int copy_sym ();
+static void mark_x ();
+
+/* ****************************************************************
+ * unexec
+ *
+ * driving logic.
+ */
+unexec (new_name, a_name, data_start, bss_start, entry_address)
+ char *new_name, *a_name;
+ unsigned data_start, bss_start, entry_address;
+{
+ int new, a_out = -1;
+
+ if (a_name && (a_out = open (a_name, O_RDONLY)) < 0)
+ {
+ PERROR (a_name);
+ }
+ if ((new = creat (new_name, 0666)) < 0)
+ {
+ PERROR (new_name);
+ }
+
+ if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0
+ || copy_text_and_data (new, a_out) < 0
+ || copy_sym (new, a_out, a_name, new_name) < 0
+#ifdef COFF
+#ifndef COFF_BSD_SYMBOLS
+ || adjust_lnnoptrs (new, a_out, new_name) < 0
+#endif
+#endif
+ )
+ {
+ close (new);
+ /* unlink (new_name); /* Failed, unlink new a.out */
+ return -1;
+ }
+
+ close (new);
+ if (a_out >= 0)
+ close (a_out);
+ mark_x (new_name);
+ return 0;
+}
+
+/* ****************************************************************
+ * make_hdr
+ *
+ * Make the header in the new a.out from the header in core.
+ * Modify the text and data sizes.
+ */
+static int
+make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name)
+ int new, a_out;
+ unsigned data_start, bss_start, entry_address;
+ char *a_name;
+ char *new_name;
+{
+ int tem;
+#ifdef COFF
+ auto struct scnhdr f_thdr; /* Text section header */
+ auto struct scnhdr f_dhdr; /* Data section header */
+ auto struct scnhdr f_bhdr; /* Bss section header */
+ auto struct scnhdr scntemp; /* Temporary section header */
+ register int scns;
+#endif /* COFF */
+#ifdef USG_SHARED_LIBRARIES
+ extern unsigned int bss_end;
+#else
+ unsigned int bss_end;
+#endif
+
+ pagemask = getpagesize () - 1;
+
+ /* Adjust text/data boundary. */
+#ifdef NO_REMAP
+ data_start = (int) start_of_data ();
+#else /* not NO_REMAP */
+ if (!data_start)
+ data_start = (int) start_of_data ();
+#endif /* not NO_REMAP */
+ data_start = ADDR_CORRECT (data_start);
+
+#ifdef SEGMENT_MASK
+ data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */
+#else
+ data_start = data_start & ~pagemask; /* (Down) to page boundary. */
+#endif
+
+ bss_end = ADDR_CORRECT (sbrk (0)) + pagemask;
+ bss_end &= ~ pagemask;
+
+ /* Adjust data/bss boundary. */
+ if (bss_start != 0)
+ {
+ bss_start = (ADDR_CORRECT (bss_start) + pagemask);
+ /* (Up) to page bdry. */
+ bss_start &= ~ pagemask;
+ if (bss_start > bss_end)
+ {
+ ERROR1 ("unexec: Specified bss_start (%u) is past end of program",
+ bss_start);
+ }
+ }
+ else
+ bss_start = bss_end;
+
+ if (data_start > bss_start) /* Can't have negative data size. */
+ {
+ ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
+ data_start, bss_start);
+ }
+
+#ifdef COFF
+ /* Salvage as much info from the existing file as possible */
+ if (a_out >= 0)
+ {
+ if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_hdr);
+ if (f_hdr.f_opthdr > 0)
+ {
+ if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_ohdr);
+ }
+ /* Loop through section headers, copying them in */
+ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0);
+ for (scns = f_hdr.f_nscns; scns > 0; scns--) {
+ if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ {
+ PERROR (a_name);
+ }
+ if (scntemp.s_scnptr > 0L)
+ {
+ if (block_copy_start < scntemp.s_scnptr + scntemp.s_size)
+ block_copy_start = scntemp.s_scnptr + scntemp.s_size;
+ }
+ if (strcmp (scntemp.s_name, ".text") == 0)
+ {
+ f_thdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".data") == 0)
+ {
+ f_dhdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".bss") == 0)
+ {
+ f_bhdr = scntemp;
+ }
+ }
+ }
+ else
+ {
+ ERROR0 ("can't build a COFF file from scratch yet");
+ }
+
+ /* Now we alter the contents of all the f_*hdr variables
+ to correspond to what we want to dump. */
+
+#ifdef USG_SHARED_LIBRARIES
+
+ /* The amount of data we're adding to the file is distance from the
+ * end of the original .data space to the current end of the .data
+ * space.
+ */
+
+ bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size);
+
+#endif
+
+ f_hdr.f_flags |= (F_RELFLG | F_EXEC);
+#ifdef TPIX
+ f_hdr.f_nscns = 3;
+#endif
+#ifdef EXEC_MAGIC
+ f_ohdr.magic = EXEC_MAGIC;
+#endif
+#ifndef NO_REMAP
+ f_ohdr.text_start = (long) start_of_text ();
+ f_ohdr.tsize = data_start - f_ohdr.text_start;
+ f_ohdr.data_start = data_start;
+#endif /* NO_REMAP */
+ f_ohdr.dsize = bss_start - f_ohdr.data_start;
+ f_ohdr.bsize = bss_end - bss_start;
+#ifndef KEEP_OLD_TEXT_SCNPTR
+ /* On some machines, the old values are right.
+ ??? Maybe on all machines with NO_REMAP. */
+ f_thdr.s_size = f_ohdr.tsize;
+ f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
+ f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
+#endif /* KEEP_OLD_TEXT_SCNPTR */
+#ifdef ADJUST_TEXT_SCNHDR_SIZE
+ /* On some machines, `text size' includes all headers. */
+ f_thdr.s_size -= f_thdr.s_scnptr;
+#endif /* ADJUST_TEST_SCNHDR_SIZE */
+ lnnoptr = f_thdr.s_lnnoptr;
+#ifdef SECTION_ALIGNMENT
+ /* Some systems require special alignment
+ of the sections in the file itself. */
+ f_thdr.s_scnptr
+ = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
+#endif /* SECTION_ALIGNMENT */
+#ifdef TPIX
+ f_thdr.s_scnptr = 0xd0;
+#endif
+ text_scnptr = f_thdr.s_scnptr;
+#ifdef ADJUST_TEXTBASE
+ text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr));
+#endif
+#ifndef KEEP_OLD_PADDR
+ f_dhdr.s_paddr = f_ohdr.data_start;
+#endif /* KEEP_OLD_PADDR */
+ f_dhdr.s_vaddr = f_ohdr.data_start;
+ f_dhdr.s_size = f_ohdr.dsize;
+ f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
+#ifdef SECTION_ALIGNMENT
+ /* Some systems require special alignment
+ of the sections in the file itself. */
+ f_dhdr.s_scnptr
+ = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
+#endif /* SECTION_ALIGNMENT */
+#ifdef DATA_SECTION_ALIGNMENT
+ /* Some systems require special alignment
+ of the data section only. */
+ f_dhdr.s_scnptr
+ = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT;
+#endif /* DATA_SECTION_ALIGNMENT */
+ data_scnptr = f_dhdr.s_scnptr;
+#ifndef KEEP_OLD_PADDR
+ f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
+#endif /* KEEP_OLD_PADDR */
+ f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
+ f_bhdr.s_size = f_ohdr.bsize;
+ f_bhdr.s_scnptr = 0L;
+#ifndef USG_SHARED_LIBRARIES
+ bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
+#endif
+
+ if (f_hdr.f_symptr > 0L)
+ {
+ f_hdr.f_symptr += bias;
+ }
+
+ if (f_thdr.s_lnnoptr > 0L)
+ {
+ f_thdr.s_lnnoptr += bias;
+ }
+
+#ifdef ADJUST_EXEC_HEADER
+ ADJUST_EXEC_HEADER;
+#endif /* ADJUST_EXEC_HEADER */
+
+ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (new_name);
+ }
+
+#ifndef USG_SHARED_LIBRARIES
+
+ if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
+ {
+ PERROR (new_name);
+ }
+
+#else /* USG_SHARED_LIBRARIES */
+
+ /* The purpose of this code is to write out the new file's section
+ * header table.
+ *
+ * Scan through the original file's sections. If the encountered
+ * section is one we know (.text, .data or .bss), write out the
+ * correct header. If it is a section we do not know (such as
+ * .lib), adjust the address of where the section data is in the
+ * file, and write out the header.
+ *
+ * If any section precedes .text or .data in the file, this code
+ * will not adjust the file pointer for that section correctly.
+ */
+
+ /* This used to use sizeof (f_ohdr) instead of .f_opthdr.
+ .f_opthdr is said to be right when there is no optional header. */
+ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0);
+
+ for (scns = f_hdr.f_nscns; scns > 0; scns--)
+ {
+ if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ PERROR (a_name);
+
+ if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */
+ {
+ if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
+ PERROR (new_name);
+ }
+ else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */
+ {
+ if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
+ PERROR (new_name);
+ }
+ else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */
+ {
+ if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
+ PERROR (new_name);
+ }
+ else
+ {
+ if (scntemp.s_scnptr)
+ scntemp.s_scnptr += bias;
+ if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ PERROR (new_name);
+ }
+ }
+#endif /* USG_SHARED_LIBRARIES */
+
+ return (0);
+
+#else /* if not COFF */
+
+ /* Get symbol table info from header of a.out file if given one. */
+ if (a_out >= 0)
+ {
+#ifdef COFF_ENCAPSULATE
+ if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader)
+ {
+ PERROR(a_name);
+ }
+ if (coffheader.f_magic != COFF_MAGIC)
+ {
+ ERROR1("%s doesn't have legal coff magic number\n", a_name);
+ }
+#endif
+ if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr)
+ {
+ PERROR (a_name);
+ }
+
+ if (N_BADMAG (ohdr))
+ {
+ ERROR1 ("invalid magic number in %s", a_name);
+ }
+ hdr = ohdr;
+ }
+ else
+ {
+#ifdef COFF_ENCAPSULATE
+ /* We probably could without too much trouble. The code is in gld
+ * but I don't have that much time or incentive.
+ */
+ ERROR0 ("can't build a COFF file from scratch yet");
+#else
+#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
+ bzero ((void *)&hdr, sizeof hdr);
+#else
+ bzero (&hdr, sizeof hdr);
+#endif
+#endif
+ }
+
+ unexec_text_start = (long) start_of_text ();
+ unexec_data_start = data_start;
+
+ /* Machine-dependent fixup for header, or maybe for unexec_text_start */
+#ifdef ADJUST_EXEC_HEADER
+ ADJUST_EXEC_HEADER;
+#endif /* ADJUST_EXEC_HEADER */
+
+ hdr.a_trsize = 0;
+ hdr.a_drsize = 0;
+ if (entry_address != 0)
+ hdr.a_entry = entry_address;
+
+ hdr.a_bss = bss_end - bss_start;
+ hdr.a_data = bss_start - data_start;
+#ifdef NO_REMAP
+ hdr.a_text = ohdr.a_text;
+#else /* not NO_REMAP */
+ hdr.a_text = data_start - unexec_text_start;
+
+#ifdef A_TEXT_OFFSET
+ hdr.a_text += A_TEXT_OFFSET (ohdr);
+#endif
+
+#endif /* not NO_REMAP */
+
+#ifdef COFF_ENCAPSULATE
+ /* We are encapsulating BSD format within COFF format. */
+ {
+ struct coffscn *tp, *dp, *bp;
+ tp = &coffheader.scns[0];
+ dp = &coffheader.scns[1];
+ bp = &coffheader.scns[2];
+ tp->s_size = hdr.a_text + sizeof(struct exec);
+ dp->s_paddr = data_start;
+ dp->s_vaddr = data_start;
+ dp->s_size = hdr.a_data;
+ bp->s_paddr = dp->s_vaddr + dp->s_size;
+ bp->s_vaddr = bp->s_paddr;
+ bp->s_size = hdr.a_bss;
+ coffheader.tsize = tp->s_size;
+ coffheader.dsize = dp->s_size;
+ coffheader.bsize = bp->s_size;
+ coffheader.text_start = tp->s_vaddr;
+ coffheader.data_start = dp->s_vaddr;
+ }
+ if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader)
+ {
+ PERROR(new_name);
+ }
+#endif /* COFF_ENCAPSULATE */
+
+ if (write (new, &hdr, sizeof hdr) != sizeof hdr)
+ {
+ PERROR (new_name);
+ }
+
+#if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */
+ /* This adjustment was done above only #ifndef NO_REMAP,
+ so only undo it now #ifndef NO_REMAP. */
+ /* #ifndef NO_REMAP */
+#endif
+#ifdef A_TEXT_OFFSET
+ hdr.a_text -= A_TEXT_OFFSET (ohdr);
+#endif
+
+ return 0;
+
+#endif /* not COFF */
+}
+
+/* ****************************************************************
+ * copy_text_and_data
+ *
+ * Copy the text and data segments from memory to the new a.out
+ */
+static int
+copy_text_and_data (new, a_out)
+ int new, a_out;
+{
+ register char *end;
+ register char *ptr;
+
+#ifdef COFF
+
+#ifdef USG_SHARED_LIBRARIES
+
+ int scns;
+ struct scnhdr scntemp; /* Temporary section header */
+
+ /* The purpose of this code is to write out the new file's section
+ * contents.
+ *
+ * Step through the section table. If we know the section (.text,
+ * .data) do the appropriate thing. Otherwise, if the section has
+ * no allocated space in the file (.bss), do nothing. Otherwise,
+ * the section has space allocated in the file, and is not a section
+ * we know. So just copy it.
+ */
+
+ lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0);
+
+ for (scns = f_hdr.f_nscns; scns > 0; scns--)
+ {
+ if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ PERROR ("temacs");
+
+ if (!strcmp (scntemp.s_name, ".text"))
+ {
+ lseek (new, (long) text_scnptr, 0);
+ ptr = (char *) f_ohdr.text_start;
+ end = ptr + f_ohdr.tsize;
+ write_segment (new, ptr, end);
+ }
+ else if (!strcmp (scntemp.s_name, ".data"))
+ {
+ lseek (new, (long) data_scnptr, 0);
+ ptr = (char *) f_ohdr.data_start;
+ end = ptr + f_ohdr.dsize;
+ write_segment (new, ptr, end);
+ }
+ else if (!scntemp.s_scnptr)
+ ; /* do nothing - no data for this section */
+ else
+ {
+ char page[BUFSIZ];
+ int size, n;
+ long old_a_out_ptr = lseek (a_out, 0, 1);
+
+ lseek (a_out, scntemp.s_scnptr, 0);
+ for (size = scntemp.s_size; size > 0; size -= sizeof (page))
+ {
+ n = size > sizeof (page) ? sizeof (page) : size;
+ if (read (a_out, page, n) != n || write (new, page, n) != n)
+ PERROR ("emacs");
+ }
+ lseek (a_out, old_a_out_ptr, 0);
+ }
+ }
+
+#else /* COFF, but not USG_SHARED_LIBRARIES */
+
+#ifdef MSDOS
+#if __DJGPP__ >= 2
+ /* Dump the original table of exception handlers, not the one
+ where our exception hooks are registered. */
+ __djgpp_exception_toggle ();
+
+ /* Switch off startup flags that might have been set at runtime
+ and which might change the way that dumped Emacs works. */
+ save_djgpp_startup_flags = _crt0_startup_flags;
+ _crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR);
+#endif
+#endif
+
+ lseek (new, (long) text_scnptr, 0);
+ ptr = (char *) f_ohdr.text_start;
+#ifdef HEADER_INCL_IN_TEXT
+ /* For Gould UTX/32, text starts after headers */
+ ptr = (char *) (ptr + text_scnptr);
+#endif /* HEADER_INCL_IN_TEXT */
+ end = ptr + f_ohdr.tsize;
+ write_segment (new, ptr, end);
+
+ lseek (new, (long) data_scnptr, 0);
+ ptr = (char *) f_ohdr.data_start;
+ end = ptr + f_ohdr.dsize;
+ write_segment (new, ptr, end);
+
+#ifdef MSDOS
+#if __DJGPP__ >= 2
+ /* Restore our exception hooks. */
+ __djgpp_exception_toggle ();
+
+ /* Restore the startup flags. */
+ _crt0_startup_flags = save_djgpp_startup_flags;
+#endif
+#endif
+
+#endif /* USG_SHARED_LIBRARIES */
+
+#else /* if not COFF */
+
+/* Some machines count the header as part of the text segment.
+ That is to say, the header appears in core
+ just before the address that start_of_text returns.
+ For them, N_TXTOFF is the place where the header goes.
+ We must adjust the seek to the place after the header.
+ Note that at this point hdr.a_text does *not* count
+ the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */
+
+#ifdef A_TEXT_SEEK
+ lseek (new, (long) A_TEXT_SEEK (hdr), 0);
+#else
+ lseek (new, (long) N_TXTOFF (hdr), 0);
+#endif /* no A_TEXT_SEEK */
+
+#ifdef RISCiX
+
+ /* Acorn's RISC-iX has a wacky way of initialising the position of the heap.
+ * There is a little table in crt0.o that is filled at link time with
+ * the min and current brk positions, among other things. When start
+ * runs, it copies the table to where these parameters live during
+ * execution. This data is in text space, so it cannot be modified here
+ * before saving the executable, so the data is written manually. In
+ * addition, the table does not have a label, and the nearest accessible
+ * label (mcount) is not prefixed with a '_', thus making it inaccessible
+ * from within C programs. To overcome this, emacs's executable is passed
+ * through the command 'nm %s | fgrep mcount' into a pipe, and the
+ * resultant output is then used to find the address of 'mcount'. As far as
+ * is possible to determine, in RISC-iX releases prior to 1.2, the negative
+ * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is
+ * 0x30. bss_end has been rounded up to page boundary. This solution is
+ * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and
+ * avoids the need for a custom version of crt0.o for emacs which has its
+ * table in data space.
+ */
+
+ {
+ char command[1024];
+ char errbuf[1024];
+ char address_text[32];
+ int proforma[4];
+ FILE *pfile;
+ char *temp_ptr;
+ char c;
+ int mcount_address, mcount_offset, count;
+ extern char *_execname;
+
+
+ /* The use of _execname is incompatible with RISCiX 1.1 */
+ sprintf (command, "nm %s | fgrep mcount", _execname);
+
+ if ( (pfile = popen(command, "r")) == NULL)
+ {
+ sprintf (errbuf, "Could not open pipe");
+ PERROR (errbuf);
+ }
+
+ count=0;
+ while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31))
+ address_text[count++]=c;
+ address_text[count]=0;
+
+ if ((count == 0) || pclose(pfile) != NULL)
+ {
+ sprintf (errbuf, "Failed to execute the command '%s'\n", command);
+ PERROR (errbuf);
+ }
+
+ sscanf(address_text, "%x", &mcount_address);
+ ptr = (char *) unexec_text_start;
+ mcount_offset = (char *)mcount_address - ptr;
+
+#ifdef RISCiX_1_1
+#define EDATA_OFFSET 0x2c
+#else
+#define EDATA_OFFSET 0x30
+#endif
+
+ end = ptr + mcount_offset - EDATA_OFFSET;
+
+ write_segment (new, ptr, end);
+
+ proforma[0] = bss_end; /* becomes _edata */
+ proforma[1] = bss_end; /* becomes _end */
+ proforma[2] = bss_end; /* becomes _minbrk */
+ proforma[3] = bss_end; /* becomes _curbrk */
+
+ write (new, proforma, 16);
+
+ temp_ptr = ptr;
+ ptr = end + 16;
+ end = temp_ptr + hdr.a_text;
+
+ write_segment (new, ptr, end);
+ }
+
+#else /* !RISCiX */
+ ptr = (char *) unexec_text_start;
+ end = ptr + hdr.a_text;
+ write_segment (new, ptr, end);
+#endif /* RISCiX */
+
+ ptr = (char *) unexec_data_start;
+ end = ptr + hdr.a_data;
+/* This lseek is certainly incorrect when A_TEXT_OFFSET
+ and I believe it is a no-op otherwise.
+ Let's see if its absence ever fails. */
+/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */
+ write_segment (new, ptr, end);
+
+#endif /* not COFF */
+
+ return 0;
+}
+
+write_segment (new, ptr, end)
+ int new;
+ register char *ptr, *end;
+{
+ register int i, nwrite, ret;
+ char buf[80];
+ extern int errno;
+ /* This is the normal amount to write at once.
+ It is the size of block that NFS uses. */
+ int writesize = 1 << 13;
+ int pagesize = getpagesize ();
+ char zeros[1 << 13];
+
+ bzero (zeros, sizeof (zeros));
+
+ for (i = 0; ptr < end;)
+ {
+ /* Distance to next multiple of writesize. */
+ nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr;
+ /* But not beyond specified end. */
+ if (nwrite > end - ptr) nwrite = end - ptr;
+ ret = write (new, ptr, nwrite);
+ /* If write gets a page fault, it means we reached
+ a gap between the old text segment and the old data segment.
+ This gap has probably been remapped into part of the text segment.
+ So write zeros for it. */
+ if (ret == -1
+#ifdef EFAULT
+ && errno == EFAULT
+#endif
+ )
+ {
+ /* Write only a page of zeros at once,
+ so that we we don't overshoot the start
+ of the valid memory in the old data segment. */
+ if (nwrite > pagesize)
+ nwrite = pagesize;
+ write (new, zeros, nwrite);
+ }
+#if 0 /* Now that we have can ask `write' to write more than a page,
+ it is legit for write do less than the whole amount specified. */
+ else if (nwrite != ret)
+ {
+ sprintf (buf,
+ "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
+ ptr, new, nwrite, ret, errno);
+ PERROR (buf);
+ }
+#endif
+ i += nwrite;
+ ptr += nwrite;
+ }
+}
+
+/* ****************************************************************
+ * copy_sym
+ *
+ * Copy the relocation information and symbol table from the a.out to the new
+ */
+static int
+copy_sym (new, a_out, a_name, new_name)
+ int new, a_out;
+ char *a_name, *new_name;
+{
+ char page[1024];
+ int n;
+
+ if (a_out < 0)
+ return 0;
+
+#ifdef COFF
+ if (SYMS_START == 0L)
+ return 0;
+#endif /* COFF */
+
+#ifdef COFF
+ if (lnnoptr) /* if there is line number info */
+ lseek (a_out, lnnoptr, 0); /* start copying from there */
+ else
+#endif /* COFF */
+ lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */
+
+ while ((n = read (a_out, page, sizeof page)) > 0)
+ {
+ if (write (new, page, n) != n)
+ {
+ PERROR (new_name);
+ }
+ }
+ if (n < 0)
+ {
+ PERROR (a_name);
+ }
+ return 0;
+}
+
+/* ****************************************************************
+ * mark_x
+ *
+ * After successfully building the new a.out, mark it executable
+ */
+static void
+mark_x (name)
+ char *name;
+{
+ struct stat sbuf;
+ int um;
+ int new = 0; /* for PERROR */
+
+ um = umask (777);
+ umask (um);
+ if (stat (name, &sbuf) == -1)
+ {
+ PERROR (name);
+ }
+ sbuf.st_mode |= 0111 & ~um;
+ if (chmod (name, sbuf.st_mode) == -1)
+ PERROR (name);
+}
+
+#ifdef COFF
+#ifndef COFF_BSD_SYMBOLS
+
+/*
+ * If the COFF file contains a symbol table and a line number section,
+ * then any auxiliary entries that have values for x_lnnoptr must
+ * be adjusted by the amount that the line number section has moved
+ * in the file (bias computed in make_hdr). The #@$%&* designers of
+ * the auxiliary entry structures used the absolute file offsets for
+ * the line number entry rather than an offset from the start of the
+ * line number section!
+ *
+ * When I figure out how to scan through the symbol table and pick out
+ * the auxiliary entries that need adjustment, this routine will
+ * be fixed. As it is now, all such entries are wrong and sdb
+ * will complain. Fred Fish, UniSoft Systems Inc.
+ */
+
+/* This function is probably very slow. Instead of reopening the new
+ file for input and output it should copy from the old to the new
+ using the two descriptors already open (WRITEDESC and READDESC).
+ Instead of reading one small structure at a time it should use
+ a reasonable size buffer. But I don't have time to work on such
+ things, so I am installing it as submitted to me. -- RMS. */
+
+adjust_lnnoptrs (writedesc, readdesc, new_name)
+ int writedesc;
+ int readdesc;
+ char *new_name;
+{
+ register int nsyms;
+ register int new;
+#if defined (amdahl_uts) || defined (pfa)
+ SYMENT symentry;
+ AUXENT auxentry;
+#else
+ struct syment symentry;
+ union auxent auxentry;
+#endif
+
+ if (!lnnoptr || !f_hdr.f_symptr)
+ return 0;
+
+#ifdef MSDOS
+ if ((new = writedesc) < 0)
+#else
+ if ((new = open (new_name, O_RDWR)) < 0)
+#endif
+ {
+ PERROR (new_name);
+ return -1;
+ }
+
+ lseek (new, f_hdr.f_symptr, 0);
+ for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++)
+ {
+ read (new, &symentry, SYMESZ);
+ if (symentry.n_numaux)
+ {
+ read (new, &auxentry, AUXESZ);
+ nsyms++;
+ if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400)
+ {
+ auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias;
+ lseek (new, -AUXESZ, 1);
+ write (new, &auxentry, AUXESZ);
+ }
+ }
+ }
+#ifndef MSDOS
+ close (new);
+#endif
+ return 0;
+}
+
+#endif /* COFF_BSD_SYMBOLS */
+
+#endif /* COFF */
+
+#endif /* not CANNOT_DUMP */
diff --git a/unexelf.c b/unexelf.c
new file mode 100644
index 0000000..60e82cc
--- /dev/null
+++ b/unexelf.c
@@ -0,0 +1,908 @@
+/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992
+ Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
+
+In other words, you are welcome to use, share and improve this program.
+You are forbidden to forbid anyone else to use, share and improve
+what you give them. Help stamp out software-hoarding! */
+
+
+/*
+ * unexec.c - Convert a running program into an a.out file.
+ *
+ * Author: Spencer W. Thomas
+ * Computer Science Dept.
+ * University of Utah
+ * Date: Tue Mar 2 1982
+ * Modified heavily since then.
+ *
+ * Synopsis:
+ * unexec (new_name, a_name, data_start, bss_start, entry_address)
+ * char *new_name, *a_name;
+ * unsigned data_start, bss_start, entry_address;
+ *
+ * Takes a snapshot of the program and makes an a.out format file in the
+ * file named by the string argument new_name.
+ * If a_name is non-NULL, the symbol table will be taken from the given file.
+ * On some machines, an existing a_name file is required.
+ *
+ * The boundaries within the a.out file may be adjusted with the data_start
+ * and bss_start arguments. Either or both may be given as 0 for defaults.
+ *
+ * Data_start gives the boundary between the text segment and the data
+ * segment of the program. The text segment can contain shared, read-only
+ * program code and literal data, while the data segment is always unshared
+ * and unprotected. Data_start gives the lowest unprotected address.
+ * The value you specify may be rounded down to a suitable boundary
+ * as required by the machine you are using.
+ *
+ * Specifying zero for data_start means the boundary between text and data
+ * should not be the same as when the program was loaded.
+ * If NO_REMAP is defined, the argument data_start is ignored and the
+ * segment boundaries are never changed.
+ *
+ * Bss_start indicates how much of the data segment is to be saved in the
+ * a.out file and restored when the program is executed. It gives the lowest
+ * unsaved address, and is rounded up to a page boundary. The default when 0
+ * is given assumes that the entire data segment is to be stored, including
+ * the previous data and bss as well as any additional storage allocated with
+ * break (2).
+ *
+ * The new file is set up to start at entry_address.
+ *
+ * If you make improvements I'd like to get them too.
+ * harpo!utah-cs!thomas, thomas@Utah-20
+ *
+ */
+
+/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co.
+ * ELF support added.
+ *
+ * Basic theory: the data space of the running process needs to be
+ * dumped to the output file. Normally we would just enlarge the size
+ * of .data, scooting everything down. But we can't do that in ELF,
+ * because there is often something between the .data space and the
+ * .bss space.
+ *
+ * In the temacs dump below, notice that the Global Offset Table
+ * (.got) and the Dynamic link data (.dynamic) come between .data1 and
+ * .bss. It does not work to overlap .data with these fields.
+ *
+ * The solution is to create a new .data segment. This segment is
+ * filled with data from the current process. Since the contents of
+ * various sections refer to sections by index, the new .data segment
+ * is made the last in the table to avoid changing any existing index.
+
+ * This is an example of how the section headers are changed. "Addr"
+ * is a process virtual address. "Offset" is a file offset.
+
+raid:/nfs/raid/src/dist-18.56/src> dump -h temacs
+
+temacs:
+
+ **** SECTION HEADER TABLE ****
+[No] Type Flags Addr Offset Size Name
+ Link Info Adralgn Entsize
+
+[1] 1 2 0x80480d4 0xd4 0x13 .interp
+ 0 0 0x1 0
+
+[2] 5 2 0x80480e8 0xe8 0x388 .hash
+ 3 0 0x4 0x4
+
+[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
+ 4 1 0x4 0x10
+
+[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
+ 0 0 0x1 0
+
+[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
+ 3 7 0x4 0x8
+
+[6] 1 6 0x8049348 0x1348 0x3 .init
+ 0 0 0x4 0
+
+[7] 1 6 0x804934c 0x134c 0x680 .plt
+ 0 0 0x4 0x4
+
+[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
+ 0 0 0x4 0
+
+[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
+ 0 0 0x4 0
+
+[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
+ 0 0 0x4 0
+
+[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
+ 0 0 0x4 0
+
+[12] 1 3 0x8088330 0x3f330 0x20afc .data
+ 0 0 0x4 0
+
+[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
+ 0 0 0x4 0
+
+[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
+ 0 0 0x4 0x4
+
+[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
+ 4 0 0x4 0x8
+
+[16] 8 3 0x80a98f4 0x608f4 0x449c .bss
+ 0 0 0x4 0
+
+[17] 2 0 0 0x608f4 0x9b90 .symtab
+ 18 371 0x4 0x10
+
+[18] 3 0 0 0x6a484 0x8526 .strtab
+ 0 0 0x1 0
+
+[19] 3 0 0 0x729aa 0x93 .shstrtab
+ 0 0 0x1 0
+
+[20] 1 0 0 0x72a3d 0x68b7 .comment
+ 0 0 0x1 0
+
+raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs
+
+xemacs:
+
+ **** SECTION HEADER TABLE ****
+[No] Type Flags Addr Offset Size Name
+ Link Info Adralgn Entsize
+
+[1] 1 2 0x80480d4 0xd4 0x13 .interp
+ 0 0 0x1 0
+
+[2] 5 2 0x80480e8 0xe8 0x388 .hash
+ 3 0 0x4 0x4
+
+[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
+ 4 1 0x4 0x10
+
+[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
+ 0 0 0x1 0
+
+[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
+ 3 7 0x4 0x8
+
+[6] 1 6 0x8049348 0x1348 0x3 .init
+ 0 0 0x4 0
+
+[7] 1 6 0x804934c 0x134c 0x680 .plt
+ 0 0 0x4 0x4
+
+[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
+ 0 0 0x4 0
+
+[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
+ 0 0 0x4 0
+
+[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
+ 0 0 0x4 0
+
+[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
+ 0 0 0x4 0
+
+[12] 1 3 0x8088330 0x3f330 0x20afc .data
+ 0 0 0x4 0
+
+[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
+ 0 0 0x4 0
+
+[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
+ 0 0 0x4 0x4
+
+[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
+ 4 0 0x4 0x8
+
+[16] 8 3 0x80c6800 0x7d800 0 .bss
+ 0 0 0x4 0
+
+[17] 2 0 0 0x7d800 0x9b90 .symtab
+ 18 371 0x4 0x10
+
+[18] 3 0 0 0x87390 0x8526 .strtab
+ 0 0 0x1 0
+
+[19] 3 0 0 0x8f8b6 0x93 .shstrtab
+ 0 0 0x1 0
+
+[20] 1 0 0 0x8f949 0x68b7 .comment
+ 0 0 0x1 0
+
+[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
+ 0 0 0x4 0
+
+ * This is an example of how the file header is changed. "Shoff" is
+ * the section header offset within the file. Since that table is
+ * after the new .data section, it is moved. "Shnum" is the number of
+ * sections, which we increment.
+ *
+ * "Phoff" is the file offset to the program header. "Phentsize" and
+ * "Shentsz" are the program and section header entries sizes respectively.
+ * These can be larger than the apparent struct sizes.
+
+raid:/nfs/raid/src/dist-18.56/src> dump -f temacs
+
+temacs:
+
+ **** ELF HEADER ****
+Class Data Type Machine Version
+Entry Phoff Shoff Flags Ehsize
+Phentsize Phnum Shentsz Shnum Shstrndx
+
+1 1 2 3 1
+0x80499cc 0x34 0x792f4 0 0x34
+0x20 5 0x28 21 19
+
+raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs
+
+xemacs:
+
+ **** ELF HEADER ****
+Class Data Type Machine Version
+Entry Phoff Shoff Flags Ehsize
+Phentsize Phnum Shentsz Shnum Shstrndx
+
+1 1 2 3 1
+0x80499cc 0x34 0x96200 0 0x34
+0x20 5 0x28 22 19
+
+ * These are the program headers. "Offset" is the file offset to the
+ * segment. "Vaddr" is the memory load address. "Filesz" is the
+ * segment size as it appears in the file, and "Memsz" is the size in
+ * memory. Below, the third segment is the code and the fourth is the
+ * data: the difference between Filesz and Memsz is .bss
+
+raid:/nfs/raid/src/dist-18.56/src> dump -o temacs
+
+temacs:
+ ***** PROGRAM EXECUTION HEADER *****
+Type Offset Vaddr Paddr
+Filesz Memsz Flags Align
+
+6 0x34 0x8048034 0
+0xa0 0xa0 5 0
+
+3 0xd4 0 0
+0x13 0 4 0
+
+1 0x34 0x8048034 0
+0x3f2f9 0x3f2f9 5 0x1000
+
+1 0x3f330 0x8088330 0
+0x215c4 0x25a60 7 0x1000
+
+2 0x60874 0x80a9874 0
+0x80 0 7 0
+
+raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs
+
+xemacs:
+ ***** PROGRAM EXECUTION HEADER *****
+Type Offset Vaddr Paddr
+Filesz Memsz Flags Align
+
+6 0x34 0x8048034 0
+0xa0 0xa0 5 0
+
+3 0xd4 0 0
+0x13 0 4 0
+
+1 0x34 0x8048034 0
+0x3f2f9 0x3f2f9 5 0x1000
+
+1 0x3f330 0x8088330 0
+0x3e4d0 0x3e4d0 7 0x1000
+
+2 0x60874 0x80a9874 0
+0x80 0 7 0
+
+
+ */
+
+/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc.
+ *
+ * The above mechanism does not work if the unexeced ELF file is being
+ * re-layout by other applications (such as `strip'). All the applications
+ * that re-layout the internal of ELF will layout all sections in ascending
+ * order of their file offsets. After the re-layout, the data2 section will
+ * still be the LAST section in the section header vector, but its file offset
+ * is now being pushed far away down, and causes part of it not to be mapped
+ * in (ie. not covered by the load segment entry in PHDR vector), therefore
+ * causes the new binary to fail.
+ *
+ * The solution is to modify the unexec algorithm to insert the new data2
+ * section header right before the new bss section header, so their file
+ * offsets will be in the ascending order. Since some of the section's (all
+ * sections AFTER the bss section) indexes are now changed, we also need to
+ * modify some fields to make them point to the right sections. This is done
+ * by macro PATCH_INDEX. All the fields that need to be patched are:
+ *
+ * 1. ELF header e_shstrndx field.
+ * 2. section header sh_link and sh_info field.
+ * 3. symbol table entry st_shndx field.
+ *
+ * The above example now should look like:
+
+ **** SECTION HEADER TABLE ****
+[No] Type Flags Addr Offset Size Name
+ Link Info Adralgn Entsize
+
+[1] 1 2 0x80480d4 0xd4 0x13 .interp
+ 0 0 0x1 0
+
+[2] 5 2 0x80480e8 0xe8 0x388 .hash
+ 3 0 0x4 0x4
+
+[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
+ 4 1 0x4 0x10
+
+[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
+ 0 0 0x1 0
+
+[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
+ 3 7 0x4 0x8
+
+[6] 1 6 0x8049348 0x1348 0x3 .init
+ 0 0 0x4 0
+
+[7] 1 6 0x804934c 0x134c 0x680 .plt
+ 0 0 0x4 0x4
+
+[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
+ 0 0 0x4 0
+
+[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
+ 0 0 0x4 0
+
+[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
+ 0 0 0x4 0
+
+[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
+ 0 0 0x4 0
+
+[12] 1 3 0x8088330 0x3f330 0x20afc .data
+ 0 0 0x4 0
+
+[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
+ 0 0 0x4 0
+
+[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
+ 0 0 0x4 0x4
+
+[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
+ 4 0 0x4 0x8
+
+[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
+ 0 0 0x4 0
+
+[17] 8 3 0x80c6800 0x7d800 0 .bss
+ 0 0 0x4 0
+
+[18] 2 0 0 0x7d800 0x9b90 .symtab
+ 19 371 0x4 0x10
+
+[19] 3 0 0 0x87390 0x8526 .strtab
+ 0 0 0x1 0
+
+[20] 3 0 0 0x8f8b6 0x93 .shstrtab
+ 0 0 0x1 0
+
+[21] 1 0 0 0x8f949 0x68b7 .comment
+ 0 0 0x1 0
+
+ */
+
+#include <sys/types.h>
+#include <stdio.h>
+#include <sys/stat.h>
+#include <memory.h>
+#include <string.h>
+#include <errno.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <elf.h>
+#include <sys/mman.h>
+
+#ifndef emacs
+#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1)
+#else
+#include <config.h>
+extern void fatal (char *, ...);
+#endif
+
+#ifndef ELF_BSS_SECTION_NAME
+#define ELF_BSS_SECTION_NAME ".bss"
+#endif
+
+/* Get the address of a particular section or program header entry,
+ * accounting for the size of the entries.
+ */
+/*
+ On PPC Reference Platform running Solaris 2.5.1
+ the plt section is also of type NOBI like the bss section.
+ (not really stored) and therefore sections after the bss
+ section start at the plt offset. The plt section is always
+ the one just before the bss section.
+ Thus, we modify the test from
+ if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
+ to
+ if (NEW_SECTION_H (nn).sh_offset >=
+ OLD_SECTION_H (old_bss_index-1).sh_offset)
+ This is just a hack. We should put the new data section
+ before the .plt section.
+ And we should not have this routine at all but use
+ the libelf library to read the old file and create the new
+ file.
+ The changed code is minimal and depends on prep set in m/prep.h
+ Erik Deumens
+ Quantum Theory Project
+ University of Florida
+ deumens@qtp.ufl.edu
+ Apr 23, 1996
+ */
+
+#define OLD_SECTION_H(n) \
+ (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
+#define NEW_SECTION_H(n) \
+ (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
+#define OLD_PROGRAM_H(n) \
+ (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
+#define NEW_PROGRAM_H(n) \
+ (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
+
+#define PATCH_INDEX(n) \
+ do { \
+ if ((int) (n) >= old_bss_index) \
+ (n)++; } while (0)
+typedef unsigned char byte;
+
+/* Round X up to a multiple of Y. */
+
+int
+round_up (x, y)
+ int x, y;
+{
+ int rem = x % y;
+ if (rem == 0)
+ return x;
+ return x - rem + y;
+}
+
+/* ****************************************************************
+ * unexec
+ *
+ * driving logic.
+ *
+ * In ELF, this works by replacing the old .bss section with a new
+ * .data section, and inserting an empty .bss immediately afterwards.
+ *
+ */
+void
+unexec (new_name, old_name, data_start, bss_start, entry_address)
+ char *new_name, *old_name;
+ unsigned data_start, bss_start, entry_address;
+{
+ int new_file, old_file, new_file_size;
+
+ /* Pointers to the base of the image of the two files. */
+ caddr_t old_base, new_base;
+
+ /* Pointers to the file, program and section headers for the old and new
+ * files.
+ */
+ Elf32_Ehdr *old_file_h, *new_file_h;
+ Elf32_Phdr *old_program_h, *new_program_h;
+ Elf32_Shdr *old_section_h, *new_section_h;
+
+ /* Point to the section name table in the old file */
+ char *old_section_names;
+
+ Elf32_Addr old_bss_addr, new_bss_addr;
+ Elf32_Word old_bss_size, new_data2_size;
+ Elf32_Off new_data2_offset;
+ Elf32_Addr new_data2_addr;
+
+ int n, nn, old_bss_index, old_data_index, new_data2_index;
+ struct stat stat_buf;
+
+ /* Open the old file & map it into the address space. */
+
+ old_file = open (old_name, O_RDONLY);
+
+ if (old_file < 0)
+ fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
+
+ if (fstat (old_file, &stat_buf) == -1)
+ fatal ("Can't fstat (%s): errno %d\n", old_name, errno);
+
+ old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0);
+
+ if (old_base == (caddr_t) -1)
+ fatal ("Can't mmap (%s): errno %d\n", old_name, errno);
+
+#ifdef DEBUG
+ fprintf (stderr, "mmap (%s, %x) -> %x\n", old_name, stat_buf.st_size,
+ old_base);
+#endif
+
+ /* Get pointers to headers & section names */
+
+ old_file_h = (Elf32_Ehdr *) old_base;
+ old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff);
+ old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff);
+ old_section_names = (char *) old_base
+ + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
+
+ /* Find the old .bss section. Figure out parameters of the new
+ * data2 and bss sections.
+ */
+
+ for (old_bss_index = 1; old_bss_index < (int) old_file_h->e_shnum;
+ old_bss_index++)
+ {
+#ifdef DEBUG
+ fprintf (stderr, "Looking for .bss - found %s\n",
+ old_section_names + OLD_SECTION_H (old_bss_index).sh_name);
+#endif
+ if (!strcmp (old_section_names + OLD_SECTION_H (old_bss_index).sh_name,
+ ELF_BSS_SECTION_NAME))
+ break;
+ }
+ if (old_bss_index == old_file_h->e_shnum)
+ fatal ("Can't find .bss in %s.\n", old_name, 0);
+
+ old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
+ old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
+#if defined(emacs) || !defined(DEBUG)
+ new_bss_addr = (Elf32_Addr) sbrk (0);
+#else
+ new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
+#endif
+ new_data2_addr = old_bss_addr;
+ new_data2_size = new_bss_addr - old_bss_addr;
+ new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset;
+
+#ifdef DEBUG
+ fprintf (stderr, "old_bss_index %d\n", old_bss_index);
+ fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
+ fprintf (stderr, "old_bss_size %x\n", old_bss_size);
+ fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
+ fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
+ fprintf (stderr, "new_data2_size %x\n", new_data2_size);
+ fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
+#endif
+
+ if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
+ fatal (".bss shrank when undumping???\n", 0, 0);
+
+ /* Set the output file to the right size and mmap it. Set
+ * pointers to various interesting objects. stat_buf still has
+ * old_file data.
+ */
+
+ new_file = open (new_name, O_RDWR | O_CREAT, 0666);
+ if (new_file < 0)
+ fatal ("Can't creat (%s): errno %d\n", new_name, errno);
+
+ new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size;
+
+ if (ftruncate (new_file, new_file_size))
+ fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
+
+#ifdef UNEXEC_USE_MAP_PRIVATE
+ new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_PRIVATE,
+ new_file, 0);
+#else
+ new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED,
+ new_file, 0);
+#endif
+
+ if (new_base == (caddr_t) -1)
+ fatal ("Can't mmap (%s): errno %d\n", new_name, errno);
+
+ new_file_h = (Elf32_Ehdr *) new_base;
+ new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff);
+ new_section_h = (Elf32_Shdr *)
+ ((byte *) new_base + old_file_h->e_shoff + new_data2_size);
+
+ /* Make our new file, program and section headers as copies of the
+ * originals.
+ */
+
+ memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
+ memcpy (new_program_h, old_program_h,
+ old_file_h->e_phnum * old_file_h->e_phentsize);
+
+ /* Modify the e_shstrndx if necessary. */
+ PATCH_INDEX (new_file_h->e_shstrndx);
+
+ /* Fix up file header. We'll add one section. Section header is
+ * further away now.
+ */
+
+ new_file_h->e_shoff += new_data2_size;
+ new_file_h->e_shnum += 1;
+
+#ifdef DEBUG
+ fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
+ fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
+ fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
+ fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
+#endif
+
+ /* Fix up a new program header. Extend the writable data segment so
+ * that the bss area is covered too. Find that segment by looking
+ * for a segment that ends just before the .bss area. Make sure
+ * that no segments are above the new .data2. Put a loop at the end
+ * to adjust the offset and address of any segment that is above
+ * data2, just in case we decide to allow this later.
+ */
+
+ for (n = new_file_h->e_phnum - 1; n >= 0; n--)
+ {
+ /* Compute maximum of all requirements for alignment of section. */
+ int alignment = (NEW_PROGRAM_H (n)).p_align;
+ if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
+ alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
+
+ if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr)
+ fatal ("Program segment above .bss in %s\n", old_name, 0);
+
+ if (NEW_PROGRAM_H (n).p_type == PT_LOAD
+ && (round_up ((NEW_PROGRAM_H (n)).p_vaddr
+ + (NEW_PROGRAM_H (n)).p_filesz,
+ alignment)
+ == round_up (old_bss_addr, alignment)))
+ break;
+ }
+ if (n < 0)
+ fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
+
+ NEW_PROGRAM_H (n).p_filesz += new_data2_size;
+ NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
+
+#if 0 /* Maybe allow section after data2 - does this ever happen? */
+ for (n = new_file_h->e_phnum - 1; n >= 0; n--)
+ {
+ if (NEW_PROGRAM_H (n).p_vaddr
+ && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
+ NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size;
+
+ if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
+ NEW_PROGRAM_H (n).p_offset += new_data2_size;
+ }
+#endif
+
+ /* Fix up section headers based on new .data2 section. Any section
+ * whose offset or virtual address is after the new .data2 section
+ * gets its value adjusted. .bss size becomes zero and new address
+ * is set. data2 section header gets added by copying the existing
+ * .data header and modifying the offset, address and size.
+ */
+ for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum;
+ old_data_index++)
+ if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
+ ".data"))
+ break;
+ if (old_data_index == old_file_h->e_shnum)
+ fatal ("Can't find .data in %s.\n", old_name, 0);
+
+ /* Walk through all section headers, insert the new data2 section right
+ before the new bss section. */
+ for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++)
+ {
+ caddr_t src;
+ /* If it is bss section, insert the new data2 section before it. */
+ if (n == old_bss_index)
+ {
+ /* Steal the data section header for this data2 section. */
+ memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
+ new_file_h->e_shentsize);
+
+ NEW_SECTION_H (nn).sh_addr = new_data2_addr;
+ NEW_SECTION_H (nn).sh_offset = new_data2_offset;
+ NEW_SECTION_H (nn).sh_size = new_data2_size;
+ /* Use the bss section's alignment. This will assure that the
+ new data2 section always be placed in the same spot as the old
+ bss section by any other application. */
+ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
+
+ /* Now copy over what we have in the memory now. */
+ memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
+ (caddr_t) OLD_SECTION_H (n).sh_addr,
+ new_data2_size);
+ nn++;
+ }
+
+ memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
+ old_file_h->e_shentsize);
+
+ /* The new bss section's size is zero, and its file offset and virtual
+ address should be off by NEW_DATA2_SIZE. */
+ if (n == old_bss_index)
+ {
+ /* NN should be `old_bss_index + 1' at this point. */
+ NEW_SECTION_H (nn).sh_offset += new_data2_size;
+ NEW_SECTION_H (nn).sh_addr += new_data2_size;
+ /* Let the new bss section address alignment be the same as the
+ section address alignment followed the old bss section, so
+ this section will be placed in exactly the same place. */
+ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
+ NEW_SECTION_H (nn).sh_size = 0;
+ }
+ else
+ {
+ /* Any section that was original placed AFTER the bss
+ section should now be off by NEW_DATA2_SIZE. */
+#ifdef SOLARIS_POWERPC
+ /* On PPC Reference Platform running Solaris 2.5.1
+ the plt section is also of type NOBI like the bss section.
+ (not really stored) and therefore sections after the bss
+ section start at the plt offset. The plt section is always
+ the one just before the bss section.
+ It would be better to put the new data section before
+ the .plt section, or use libelf instead.
+ Erik Deumens, deumens@qtp.ufl.edu. */
+ if (NEW_SECTION_H (nn).sh_offset
+ >= OLD_SECTION_H (old_bss_index-1).sh_offset)
+ NEW_SECTION_H (nn).sh_offset += new_data2_size;
+#else
+ if (round_up (NEW_SECTION_H (nn).sh_offset,
+ OLD_SECTION_H (old_bss_index).sh_addralign)
+ >= new_data2_offset)
+ NEW_SECTION_H (nn).sh_offset += new_data2_size;
+#endif
+ /* Any section that was originally placed after the section
+ header table should now be off by the size of one section
+ header table entry. */
+ if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff)
+ NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize;
+ }
+
+ /* If any section hdr refers to the section after the new .data
+ section, make it refer to next one because we have inserted
+ a new section in between. */
+
+ PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
+ /* For symbol tables, info is a symbol table index,
+ so don't change it. */
+ if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
+ && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
+ PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
+
+ /* Now, start to copy the content of sections. */
+ if (NEW_SECTION_H (nn).sh_type == SHT_NULL
+ || NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
+ continue;
+
+ /* Write out the sections. .data and .data1 (and data2, called
+ ".data" in the strings table) get copied from the current process
+ instead of the old file. */
+ if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data")
+ || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
+ ".data1"))
+ src = (caddr_t) OLD_SECTION_H (n).sh_addr;
+ else
+ src = old_base + OLD_SECTION_H (n).sh_offset;
+
+ memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
+ NEW_SECTION_H (nn).sh_size);
+
+ /* If it is the symbol table, its st_shndx field needs to be patched. */
+ if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
+ || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
+ {
+ Elf32_Shdr *spt = &NEW_SECTION_H (nn);
+ unsigned int num = spt->sh_size / spt->sh_entsize;
+ Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset +
+ new_base);
+ for (; num--; sym++)
+ {
+ if ((sym->st_shndx == SHN_UNDEF)
+ || (sym->st_shndx == SHN_ABS)
+ || (sym->st_shndx == SHN_COMMON))
+ continue;
+
+ PATCH_INDEX (sym->st_shndx);
+ }
+ }
+ }
+
+ /* Update the symbol values of _edata and _end. */
+ for (n = new_file_h->e_shnum - 1; n; n--)
+ {
+ byte *symnames;
+ Elf32_Sym *symp, *symendp;
+
+ if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM
+ && NEW_SECTION_H (n).sh_type != SHT_SYMTAB)
+ continue;
+
+ symnames = ((byte *) new_base
+ + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset);
+ symp = (Elf32_Sym *) (NEW_SECTION_H (n).sh_offset + new_base);
+ symendp = (Elf32_Sym *) ((byte *)symp + NEW_SECTION_H (n).sh_size);
+
+ for (; symp < symendp; symp ++)
+ if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0
+ || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0)
+ memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr));
+ }
+
+ /* This loop seeks out relocation sections for the data section, so
+ that it can undo relocations performed by the runtime linker. */
+ for (n = new_file_h->e_shnum - 1; n; n--)
+ {
+ Elf32_Shdr section = NEW_SECTION_H (n);
+ switch (section.sh_type) {
+ default:
+ break;
+ case SHT_REL:
+ case SHT_RELA:
+ /* This code handles two different size structs, but there should
+ be no harm in that provided that r_offset is always the first
+ member. */
+ nn = section.sh_info;
+ if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
+ || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
+ ".data1"))
+ {
+ Elf32_Addr offset = NEW_SECTION_H (nn).sh_addr -
+ NEW_SECTION_H (nn).sh_offset;
+ caddr_t reloc = old_base + section.sh_offset, end;
+ for (end = reloc + section.sh_size; reloc < end;
+ reloc += section.sh_entsize)
+ {
+ Elf32_Addr addr = ((Elf32_Rel *) reloc)->r_offset - offset;
+ memcpy (new_base + addr, old_base + addr, 4);
+ }
+ }
+ break;
+ }
+ }
+
+#ifdef UNEXEC_USE_MAP_PRIVATE
+ if (lseek (new_file, 0, SEEK_SET) == -1)
+ fatal ("Can't rewind (%s): errno %d\n", new_name, errno);
+
+ if (write (new_file, new_base, new_file_size) != new_file_size)
+ fatal ("Can't write (%s): errno %d\n", new_name, errno);
+#endif
+
+ /* Close the files and make the new file executable. */
+
+ if (close (old_file))
+ fatal ("Can't close (%s): errno %d\n", old_name, errno);
+
+ if (close (new_file))
+ fatal ("Can't close (%s): errno %d\n", new_name, errno);
+
+ if (stat (new_name, &stat_buf) == -1)
+ fatal ("Can't stat (%s): errno %d\n", new_name, errno);
+
+ n = umask (777);
+ umask (n);
+ stat_buf.st_mode |= 0111 & ~n;
+ if (chmod (new_name, stat_buf.st_mode) == -1)
+ fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
+}
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, (k<LENGTH_MAX ? k : LENGTH_MAX), type);
+ ALLOW_INTS;
+ return v;
+}
+
+static char s_uve_len[] = "uniform-vector-length";
+SCM uve_len(v)
+ SCM v;
+{
+ ASRTGO(NIMP(v), badarg1);
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_uve_len);
+ case tc7_bvect:
+ case tc7_string:
+ case tc7_uvect:
+ case tc7_ivect:
+ case tc7_fvect:
+ case tc7_dvect:
+ case tc7_cvect:
+ case tc7_vector:
+ return MAKINUM(LENGTH(v));
+ }
+}
+
+SCM arrayp(v, prot)
+ SCM v, prot;
+{
+ int nprot = UNBNDP(prot), enclosed = 0;
+ if IMP(v) return BOOL_F;
+ loop:
+ switch TYP7(v) {
+ case tc7_smob: if (!ARRAYP(v)) return BOOL_F;
+ if (nprot) return BOOL_T;
+ if (enclosed++) return BOOL_F;
+ v = ARRAY_V(v);
+ goto loop;
+ case tc7_bvect: return nprot || BOOL_T==prot ? BOOL_T : BOOL_F;
+ case tc7_string: return nprot || ICHRP(prot) ? BOOL_T : BOOL_F;
+ case tc7_uvect:
+ return nprot || (INUMP(prot) && INUM(prot)>0) ? BOOL_T : BOOL_F;
+ case tc7_ivect:
+ return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F;
+# endif
+ case tc7_dvect: return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F;
+ case tc7_cvect: return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F;
+# endif
+ case tc7_vector: return nprot || NULLP(prot) ? BOOL_T : BOOL_F;
+ default:;
+ }
+ return BOOL_F;
+}
+SCM array_rank(ra)
+ SCM ra;
+{
+ if IMP(ra) return INUM0;
+ switch (TYP7(ra)) {
+ default: return INUM0;
+ case tc7_string: case tc7_vector: case tc7_bvect:
+ case tc7_uvect: case tc7_ivect: case tc7_fvect:
+ case tc7_cvect: case tc7_dvect:
+ return MAKINUM(1L);
+ case tc7_smob:
+ if ARRAYP(ra) return MAKINUM(ARRAY_NDIM(ra));
+ return INUM0;
+ }
+}
+static char s_array_dims[] = "array-dimensions";
+SCM array_dims(ra)
+ SCM ra;
+{
+ SCM res=EOL;
+ sizet k;
+ array_dim *s;
+ if IMP(ra) return BOOL_F;
+ switch (TYP7(ra)) {
+ default: return BOOL_F;
+ case tc7_string: case tc7_vector: case tc7_bvect:
+ case tc7_uvect: case tc7_ivect: case tc7_fvect:
+ case tc7_cvect: case tc7_dvect:
+ return cons(MAKINUM(LENGTH(ra)), EOL);
+ case tc7_smob:
+ if (!ARRAYP(ra)) return BOOL_F;
+ k = ARRAY_NDIM(ra);
+ s = ARRAY_DIMS(ra);
+ while (k--)
+ res = cons(s[k].lbnd ? cons2(MAKINUM(s[k].lbnd), MAKINUM(s[k].ubnd), EOL) :
+ MAKINUM(1+(s[k].ubnd))
+ , res);
+ return res;
+ }
+}
+static char s_bad_ind[] = "Bad array index";
+long aind(ra, args, what)
+ SCM ra, args;
+ char *what;
+{
+ SCM ind;
+ register long j;
+ register sizet pos = ARRAY_BASE(ra);
+ register sizet k = ARRAY_NDIM(ra);
+ array_dim *s = ARRAY_DIMS(ra);
+ if INUMP(args) {
+ ASSERT(1==k, UNDEFINED, WNA, what);
+ j = INUM(args);
+ ASSERT(j >= (s->lbnd) && j <= (s->ubnd), args, OUTOFRANGE, what);
+ return pos + (j - s->lbnd)*(s->inc);
+ }
+ ASSERT((IMP(args) ? NULLP(args) : CONSP(args)), args, s_bad_ind, what);
+ while (k && NIMP(args)) {
+ ind = CAR(args);
+ args = CDR(args);
+ ASSERT(INUMP(ind), ind, s_bad_ind, what);
+ j = INUM(ind);
+ ASSERT(j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what);
+ pos += (j - s->lbnd)*(s->inc);
+ k--;
+ s++;
+ }
+ ASSERT(0==k && NULLP(args), UNDEFINED, WNA, what);
+ return pos;
+}
+
+SCM make_ra(ndim)
+ int ndim;
+{
+ SCM ra;
+ NEWCELL(ra);
+ DEFER_INTS;
+ SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)),
+ "array"));
+ CAR(ra) = ((long)ndim << 17) + tc16_array;
+ ARRAY_V(ra) = nullvect;
+ ALLOW_INTS;
+ return ra;
+}
+
+static char s_bad_spec[] = "Bad array dimension";
+/* Increments will still need to be set. */
+SCM shap2ra(args, what)
+ SCM args;
+ char *what;
+{
+ array_dim *s;
+ SCM ra, spec, sp;
+ int ndim = ilength(args);
+ ASSERT(0 <= ndim, args, s_bad_spec, what);
+ ra = make_ra(ndim);
+ ARRAY_BASE(ra) = 0;
+ s = ARRAY_DIMS(ra);
+ for (; NIMP(args); s++, args = CDR(args)) {
+ spec = CAR(args);
+ if IMP(spec) {
+ ASSERT(INUMP(spec)&&INUM(spec)>=0, spec, s_bad_spec, what);
+ s->lbnd = 0;
+ s->ubnd = INUM(spec) - 1;
+ s->inc = 1;
+ }
+ else {
+ ASSERT(CONSP(spec) && INUMP(CAR(spec)), spec, s_bad_spec, what);
+ s->lbnd = INUM(CAR(spec));
+ sp = CDR(spec);
+ ASSERT(INUMP(CAR(sp)) && NULLP(CDR(sp)),
+ spec, s_bad_spec, what);
+ s->ubnd = INUM(CAR(sp));
+ s->inc = 1;
+ }
+ }
+ return ra;
+}
+
+static char s_uve_fill[] = "uniform-vector-fill!";
+int rafill(ra, fill, ignore)
+ SCM ra, fill, ignore;
+{
+ sizet i, n;
+ long inc = 1;
+ sizet base = 0;
+ if ARRAYP(ra) {
+ n = ARRAY_DIMS(ra)->ubnd - ARRAY_DIMS(ra)->lbnd + 1;
+ inc = ARRAY_DIMS(ra)->inc;
+ base = ARRAY_BASE(ra);
+ ra = ARRAY_V(ra);
+ }
+ else
+ n = LENGTH(ra);
+ switch TYP7(ra) {
+ badarg2: wta(fill, (char *)ARG2, s_uve_fill);
+ default: ASSERT(NFALSEP(arrayp(ra, UNDEFINED)), ra, ARG1, s_uve_fill);
+ for (i = base; n--; i += inc)
+ aset(ra, fill, MAKINUM(i));
+ break;
+ case tc7_vector: {
+ SCM *ve = VELTS(ra);
+ for (i = base; n--; i += inc)
+ ve[i] = fill;
+ break;
+ }
+ case tc7_string: {
+ char *ve = CHARS(ra);
+ SCM f = ICHR(fill);
+ ASRTGO(ICHRP(fill), badarg2);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+ case tc7_bvect: {
+ long *ve = (long *)VELTS(ra);
+ if (1==inc && (n >= LONG_BIT || n==LENGTH(ra))) {
+ i = base/LONG_BIT;
+ if (BOOL_F==fill) {
+ if (base % LONG_BIT) /* leading partial word */
+ ve[i++] &= ~(~0L << (base % LONG_BIT));
+ for (; i < (base + n)/LONG_BIT; i++)
+ ve[i] = 0L;
+ if ((base + n) % LONG_BIT) /* trailing partial word */
+ ve[i] &= (~0L << ((base + n) % LONG_BIT));
+ }
+ else if (BOOL_T==fill) {
+ if (base % LONG_BIT)
+ ve[i++] |= ~0L << (base % LONG_BIT);
+ for (; i < (base + n)/LONG_BIT; i++)
+ ve[i] = ~0L;
+ if ((base + n) % LONG_BIT)
+ ve[i] |= ~(~0L << ((base + n) % LONG_BIT));
+ }
+ else goto badarg2;
+ }
+ else {
+ if (BOOL_F==fill)
+ for (i = base; n--; i += inc)
+ ve[i/LONG_BIT] &= ~(1L<<(i%LONG_BIT));
+ else if (BOOL_T==fill)
+ for (i = base; n--; i += inc)
+ ve[i/LONG_BIT] |= (1L<<(i%LONG_BIT));
+ else goto badarg2;
+ }
+ break;
+ }
+ case tc7_uvect:
+ case tc7_ivect:
+ {
+ long *ve = VELTS(ra);
+ long f = (tc7_uvect==TYP7(ra) ?
+ num2ulong(fill, (char *)ARG2, s_uve_fill) :
+ num2long(fill, (char *)ARG2, s_uve_fill));
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *ve = (float *)VELTS(ra);
+ float f = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+# endif /* SINGLES */
+ case tc7_dvect: {
+ double *ve = (double *)VELTS(ra);
+ double f = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ for (i = base; n--; i += inc)
+ ve[i] = f;
+ break;
+ }
+ case tc7_cvect: {
+ double fr, fi=0.0;
+ double (*ve)[2] = (double (*)[2])VELTS(ra);
+ if (NIMP(fill) && CPLXP(fill)) {
+ fr = REAL(fill);
+ fi = IMAG(fill);
+ }
+ else
+ fr = num2dbl(fill, (char *)ARG2, s_uve_fill);
+ for (i = base; n--; i += inc) {
+ ve[i][0] = fr;
+ ve[i][1] = fi;
+ }
+ break;
+ }
+# endif /* FLOATS */
+ }
+ return 1;
+}
+SCM uve_fill(uve, fill)
+ SCM uve, fill;
+{
+
+ ASSERT(NIMP(uve) && (!ARRAYP(uve) || 1==ARRAY_NDIM(uve)),
+ uve, ARG1, s_uve_fill);
+ rafill(uve, fill, EOL);
+ return UNSPECIFIED;
+}
+
+static char s_dims2ura[] = "dimensions->uniform-array";
+SCM dims2ura(dims, prot, fill)
+ SCM dims, prot, fill;
+{
+ sizet k, vlen = 1;
+ long rlen = 1;
+ array_dim *s;
+ SCM ra;
+ if INUMP(dims)
+ if (INUM(dims) < LENGTH_MAX) {
+ ra = make_uve(INUM(dims), prot);
+ if NNULLP(fill)
+ rafill(ra, CAR(fill), EOL);
+ return ra;
+ }
+ else
+ dims = cons(dims, EOL);
+ ASSERT(NULLP(dims) || (NIMP(dims) && CONSP(dims)), dims, ARG1, s_dims2ura);
+ ra = shap2ra(dims, s_dims2ura);
+ CAR(ra) |= ARRAY_CONTIGUOUS;
+ s = ARRAY_DIMS(ra);
+ k = ARRAY_NDIM(ra);
+ while (k--) {
+ s[k].inc = (rlen > 0 ? rlen : 0);
+ rlen = (s[k].ubnd - s[k].lbnd + 1)*s[k].inc;
+ vlen *= (s[k].ubnd - s[k].lbnd + 1);
+ }
+ if (rlen < LENGTH_MAX)
+ ARRAY_V(ra) = make_uve((rlen > 0 ? rlen : 0L), prot);
+ else {
+ sizet bit;
+ switch TYP7(make_uve(0L, prot)) {
+ default: bit = LONG_BIT; break;
+ case tc7_vector: wta(dims, (char *)OUTOFRANGE, s_dims2ura);
+ case tc7_bvect: bit = 1; break;
+ case tc7_string: bit = CHAR_BIT; break;
+ case tc7_fvect: bit = sizeof(float)*CHAR_BIT/sizeof(char); break;
+ case tc7_dvect: bit = sizeof(double)*CHAR_BIT/sizeof(char); break;
+ case tc7_cvect: bit = 2*sizeof(double)*CHAR_BIT/sizeof(char); break;
+ }
+ ARRAY_BASE(ra) = (LONG_BIT + bit - 1)/bit;
+ rlen += ARRAY_BASE(ra);
+ ARRAY_V(ra) = make_uve(rlen, prot);
+ *((long *)VELTS(ARRAY_V(ra))) = rlen;
+ }
+ if NNULLP(fill) {
+ ASSERT(1==ilength(fill), UNDEFINED, WNA, s_dims2ura);
+ rafill(ARRAY_V(ra), CAR(fill), EOL);
+ }
+ if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra))
+ if (s->ubnd < s->lbnd || (0==s->lbnd && 1==s->inc)) return ARRAY_V(ra);
+ return ra;
+}
+
+void ra_set_contp(ra)
+ SCM ra;
+{
+ sizet k = ARRAY_NDIM(ra);
+ long inc;
+ if (k) inc = ARRAY_DIMS(ra)[k-1].inc;
+ while (k--) {
+ if (inc != ARRAY_DIMS(ra)[k].inc) {
+ CAR(ra) &= ~ARRAY_CONTIGUOUS;
+ return;
+ }
+ inc *= (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1);
+ }
+ CAR(ra) |= ARRAY_CONTIGUOUS;
+}
+char s_make_sh_array[] = "make-shared-array";
+SCM make_sh_array(oldra, mapfunc, dims)
+ SCM oldra;
+ SCM mapfunc;
+ SCM dims;
+{
+ SCM ra;
+ SCM inds, indptr;
+ SCM imap;
+ sizet i, k;
+ long old_min, new_min, old_max, new_max;
+ array_dim *s;
+ ASSERT(BOOL_T==procedurep(mapfunc), mapfunc, ARG2, s_make_sh_array);
+ ASSERT(NIMP(oldra) && arrayp(oldra, UNDEFINED), oldra, ARG1, s_make_sh_array);
+ ra = shap2ra(dims, s_make_sh_array);
+ if (ARRAYP(oldra)) {
+ ARRAY_V(ra) = ARRAY_V(oldra);
+ old_min = old_max = ARRAY_BASE(oldra);
+ s=ARRAY_DIMS(oldra);
+ k = ARRAY_NDIM(oldra);
+ while (k--) {
+ if (s[k].inc > 0)
+ old_max += (s[k].ubnd - s[k].lbnd)*s[k].inc;
+ else
+ old_min += (s[k].ubnd - s[k].lbnd)*s[k].inc;
+ }
+ }
+ else {
+ ARRAY_V(ra) = oldra;
+ old_min = 0;
+ old_max = (long)LENGTH(oldra) - 1;
+ }
+ inds = EOL;
+ s = ARRAY_DIMS(ra);
+ for (k = 0; k < ARRAY_NDIM(ra); k++) {
+ inds = cons(MAKINUM(s[k].lbnd), inds);
+ if (s[k].ubnd < s[k].lbnd) {
+ if (1==ARRAY_NDIM(ra))
+ ra = make_uve(0L, array_prot(ra));
+ else
+ ARRAY_V(ra) = make_uve(0L, array_prot(ra));
+ return ra;
+ }
+ }
+ imap = apply(mapfunc, reverse(inds), EOL);
+ if ARRAYP(oldra)
+ i = (sizet)aind(oldra, imap, s_make_sh_array);
+ else {
+ if NINUMP(imap) {
+ ASSERT(1==ilength(imap) && INUMP(CAR(imap)),
+ imap, s_bad_ind, s_make_sh_array);
+ imap = CAR(imap);
+ }
+ i = INUM(imap);
+ }
+ ARRAY_BASE(ra) = new_min = new_max = i;
+ indptr = inds;
+ k = ARRAY_NDIM(ra);
+ while (k--) {
+ if (s[k].ubnd > s[k].lbnd) {
+ CAR(indptr) = MAKINUM(INUM(CAR(indptr))+1);
+ imap = apply(mapfunc, reverse(inds), EOL);
+ if ARRAYP(oldra)
+ s[k].inc = aind(oldra, imap, s_make_sh_array) - i;
+ else {
+ if NINUMP(imap) {
+ ASSERT(1==ilength(imap) && INUMP(CAR(imap)),
+ imap, s_bad_ind, s_make_sh_array);
+ imap = CAR(imap);
+ }
+ s[k].inc = (long)INUM(imap) - i;
+ }
+ i += s[k].inc;
+ if (s[k].inc > 0)
+ new_max += (s[k].ubnd - s[k].lbnd)*s[k].inc;
+ else
+ new_min += (s[k].ubnd - s[k].lbnd)*s[k].inc;
+ }
+ else
+ s[k].inc = new_max - new_min + 1; /* contiguous by default */
+ indptr = CDR(indptr);
+ }
+ ASSERT(old_min <= new_min && old_max >= new_max, UNDEFINED,
+ "mapping out of range", s_make_sh_array);
+ if (1==ARRAY_NDIM(ra) && 0==ARRAY_BASE(ra)) {
+ if (1==s->inc && 0==s->lbnd
+ && LENGTH(ARRAY_V(ra))==1+s->ubnd) return ARRAY_V(ra);
+ if (s->ubnd < s->lbnd) return make_uve(0L, array_prot(ra));
+ }
+ ra_set_contp(ra);
+ return ra;
+}
+
+/* args are RA . DIMS */
+static char s_trans_array[] = "transpose-array";
+SCM trans_array(args)
+ SCM args;
+{
+ SCM ra, res, vargs, *ve = &vargs;
+ array_dim *s, *r;
+ int ndim, i, k;
+ ASSERT(NIMP(args), UNDEFINED, WNA, s_trans_array);
+ ra = CAR(args);
+ args = CDR(args);
+ switch TYP7(ra) {
+ default: badarg: wta(ra, (char *)ARG1, s_trans_array);
+ case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
+ ASSERT(NIMP(args) && NULLP(CDR(args)), UNDEFINED, WNA, s_trans_array);
+ ASSERT(INUM0==CAR(args), CAR(args), ARG1, s_trans_array);
+ return ra;
+ case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
+ vargs = vector(args);
+ ASSERT(LENGTH(vargs)==ARRAY_NDIM(ra), UNDEFINED, WNA, s_trans_array);
+ ve = VELTS(vargs);
+ ndim = 0;
+ for (k = 0; k < ARRAY_NDIM(ra); k++) {
+ i = INUM(ve[k]);
+ ASSERT(INUMP(ve[k]) && i >=0 && i < ARRAY_NDIM(ra),
+ ve[k], ARG2, s_trans_array);
+ if (ndim < i) ndim = i;
+ }
+ ndim++;
+ res = make_ra(ndim);
+ ARRAY_V(res) = ARRAY_V(ra);
+ ARRAY_BASE(res) = ARRAY_BASE(ra);
+ for (k = ndim; k--;) {
+ ARRAY_DIMS(res)[k].lbnd = 0;
+ ARRAY_DIMS(res)[k].ubnd = -1;
+ }
+ for (k = ARRAY_NDIM(ra); k--;) {
+ i = INUM(ve[k]);
+ s = &(ARRAY_DIMS(ra)[k]);
+ r = &(ARRAY_DIMS(res)[i]);
+ if (r->ubnd < r->lbnd) {
+ r->lbnd = s->lbnd;
+ r->ubnd = s->ubnd;
+ r->inc = s->inc;
+ ndim--;
+ }
+ else {
+ if (r->ubnd > s->ubnd)
+ r->ubnd = s->ubnd;
+ if (r->lbnd < s->lbnd) {
+ ARRAY_BASE(res) += (s->lbnd - r->lbnd)*r->inc;
+ r->lbnd = s->lbnd;
+ }
+ r->inc += s->inc;
+ }
+ }
+ ASSERT(ndim <= 0, args, "bad argument list", s_trans_array);
+ ra_set_contp(res);
+ return res;
+ }
+}
+
+/* args are RA . AXES */
+static char s_encl_array[] = "enclose-array";
+SCM encl_array(axes)
+ SCM axes;
+{
+ SCM axv, ra, res, ra_inr;
+ array_dim vdim, *s = &vdim;
+ int ndim, j, k, ninr, noutr;
+ ASSERT(NIMP(axes), UNDEFINED, WNA, s_encl_array);
+ ra = CAR(axes);
+ axes = CDR(axes);
+ if NULLP(axes)
+ axes = cons((ARRAYP(ra) ? MAKINUM(ARRAY_NDIM(ra) - 1) : INUM0), EOL);
+ ninr = ilength(axes);
+ ra_inr = make_ra(ninr);
+ ASRTGO(NIMP(ra), badarg1);
+ switch TYP7(ra) {
+ default: badarg1: wta(ra, (char *)ARG1, s_encl_array);
+ case tc7_string: case tc7_bvect: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
+ s->lbnd = 0;
+ s->ubnd = LENGTH(ra) - 1;
+ s->inc = 1;
+ ARRAY_V(ra_inr) = ra;
+ ARRAY_BASE(ra_inr) = 0;
+ ndim = 1;
+ break;
+ case tc7_smob: ASRTGO(ARRAYP(ra), badarg1);
+ s = ARRAY_DIMS(ra);
+ ARRAY_V(ra_inr) = ARRAY_V(ra);
+ ARRAY_BASE(ra_inr) = ARRAY_BASE(ra);
+ ndim = ARRAY_NDIM(ra);
+ break;
+ }
+ noutr = ndim - ninr;
+ axv = make_string(MAKINUM(ndim), MAKICHR(0));
+ ASSERT(0 <= noutr && 0 <= ninr, UNDEFINED, WNA, s_encl_array);
+ res = make_ra(noutr);
+ ARRAY_BASE(res) = ARRAY_BASE(ra_inr);
+ ARRAY_V(res) = ra_inr;
+ for (k = 0; k < ninr; k++, axes = CDR(axes)) {
+ j = INUM(CAR(axes));
+ ASSERT(INUMP(CAR(axes)) && j<ndim, CAR(axes), "bad axis", s_encl_array);
+ ARRAY_DIMS(ra_inr)[k].lbnd = s[j].lbnd;
+ ARRAY_DIMS(ra_inr)[k].ubnd = s[j].ubnd;
+ ARRAY_DIMS(ra_inr)[k].inc = s[j].inc;
+ CHARS(axv)[j] = 1;
+ }
+ for (j = 0, k = 0; k < noutr; k++, j++) {
+ while (CHARS(axv)[j]) j++;
+ ARRAY_DIMS(res)[k].lbnd = s[j].lbnd;
+ ARRAY_DIMS(res)[k].ubnd = s[j].ubnd;
+ ARRAY_DIMS(res)[k].inc = s[j].inc;
+ }
+ ra_set_contp(ra_inr);
+ ra_set_contp(res);
+ return res;
+}
+
+static char s_array_inbp[] = "array-in-bounds?";
+SCM array_inbp(args)
+ SCM args;
+{
+ SCM v, ind = EOL;
+ register long j;
+ ASRTGO(NIMP(args), wna);
+ v = CAR(args);
+ args = CDR(args);
+ if IMP(v) goto scalar;
+ switch TYP7(v) {
+ default:
+ scalar: if NULLP(args) return BOOL_T;
+ badarg1: wta(v, (char *)ARG1, s_array_inbp);
+ wna: wta(UNDEFINED, (char *)WNA, s_array_inbp);
+ case tc7_smob:
+ if (ARRAYP(v)) {
+ SCM ret = BOOL_T;
+ register sizet k = ARRAY_NDIM(v);
+ array_dim *s = ARRAY_DIMS(v);
+ while (k && NIMP(args)) {
+ ind = CAR(args);
+ args = CDR(args);
+ ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp);
+ j = INUM(ind);
+ if (j < (s->lbnd) || j > (s->ubnd)) ret = BOOL_F;
+ k--;
+ s++;
+ }
+ ASRTGO(0==k && NULLP(args), wna);
+ return ret;
+ }
+ else goto scalar;
+ case tc7_bvect: case tc7_string: case tc7_uvect: case tc7_ivect:
+ case tc7_fvect: case tc7_dvect: case tc7_cvect: case tc7_vector:
+ ASRTGO(NIMP(args) && NULLP(CDR(args)), wna);
+ ind = CAR(args);
+ ASSERT(INUMP(ind), ind, s_bad_ind, s_array_inbp);
+ j = INUM(ind);
+ return j >= 0 && j < LENGTH(v) ? BOOL_T : BOOL_F;
+ }
+}
+static char s_aref[] = "array-ref";
+SCM aref(v, args)
+ SCM v, args;
+{
+ long pos;
+ if IMP(v) {
+ ASRTGO(NULLP(args), badarg);
+ return v;
+ }
+ else if ARRAYP(v) {
+ pos = aind(v, args, s_aref);
+ v = ARRAY_V(v);
+ }
+ else {
+ if NIMP(args) {
+ ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aref);
+ pos = INUM(CAR(args));
+ ASRTGO(NULLP(CDR(args)), wna);
+ }
+ else {
+ ASSERT(INUMP(args), args, ARG2, s_aref);
+ pos = INUM(args);
+ }
+ ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
+ }
+ switch TYP7(v) {
+ default: if NULLP(args) return v;
+ badarg: wta(v, (char *)ARG1, s_aref);
+ outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aref);
+ wna: wta(UNDEFINED, (char *)WNA, s_aref);
+ case tc7_smob: { /* enclosed */
+ int k = ARRAY_NDIM(v);
+ SCM res = make_ra(k);
+ if (!ARRAYP(v)) {
+ ASRTGO(NULLP(args),badarg);
+ return v;
+ }
+ ARRAY_V(res) = ARRAY_V(v);
+ ARRAY_BASE(res) = pos;
+ while (k--) {
+ ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(v)[k].lbnd;
+ ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(v)[k].ubnd;
+ ARRAY_DIMS(res)[k].inc = ARRAY_DIMS(v)[k].inc;
+ }
+ return res;
+ }
+ case tc7_bvect:
+ if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT)))
+ return BOOL_T;
+ else return BOOL_F;
+ case tc7_string:
+ return MAKICHR(CHARS(v)[pos]);
+# ifdef INUMS_ONLY
+ case tc7_uvect:
+ case tc7_ivect:
+ return MAKINUM(VELTS(v)[pos]);
+# else
+ case tc7_uvect:
+ return ulong2num(VELTS(v)[pos]);
+ case tc7_ivect:
+ return long2num(VELTS(v)[pos]);
+# endif
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ return makflo(((float *)CDR(v))[pos]);
+# endif
+ case tc7_dvect:
+ return makdbl(((double *)CDR(v))[pos], 0.0);
+ case tc7_cvect:
+ return makdbl(((double *)CDR(v))[2*pos],
+ ((double *)CDR(v))[2*pos+1]);
+# endif
+ case tc7_vector:
+ return VELTS(v)[pos];
+ }
+}
+SCM scm_array_ref(args)
+ SCM args;
+{
+ ASSERT(NIMP(args), UNDEFINED, WNA, s_aref);
+ return aref(CAR(args), CDR(args));
+}
+
+/* Internal version of aref for uves that does no error checking and
+ tries to recycle conses. (Make *sure* you want them recycled.) */
+SCM cvref(v, pos, last)
+ SCM v;
+ sizet pos;
+ SCM last;
+{
+ switch TYP7(v) {
+ default: wta(v, (char *)ARG1, "PROGRAMMING ERROR: cvref");
+ case tc7_bvect:
+ if (VELTS(v)[pos/LONG_BIT]&(1L<<(pos%LONG_BIT)))
+ return BOOL_T;
+ else return BOOL_F;
+ case tc7_string:
+ return MAKICHR(CHARS(v)[pos]);
+# ifdef INUMS_ONLY
+ case tc7_uvect:
+ case tc7_ivect:
+ return MAKINUM(VELTS(v)[pos]);
+# else
+ case tc7_uvect:
+ return ulong2num(VELTS(v)[pos]);
+ case tc7_ivect:
+ return long2num(VELTS(v)[pos]);
+# endif
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) {
+ FLO(last) = ((float *)CDR(v))[pos];
+ return last;
+ }
+ return makflo(((float *)CDR(v))[pos]);
+# endif
+ case tc7_cvect:
+ if (0.0!=((double *)CDR(v))[2*pos+1]) {
+ if (NIMP(last) && tc_dblc==CAR(last)) {
+ REAL(last) = ((double *)CDR(v))[2*pos];
+ IMAG(last) = ((double *)CDR(v))[2*pos+1];
+ return last;
+ }
+ return makdbl(((double *)CDR(v))[2*pos],
+ ((double *)CDR(v))[2*pos+1]);
+ }
+ else pos *= 2;
+ /* Fall through */
+ case tc7_dvect:
+# ifdef CDR_DOUBLES
+ if (NIMP(last) && (last != flo0) && (tc_flo==CAR(last))) {
+ FLO(last) = ((double *)CDR(v))[pos];
+ return last;
+ }
+# else
+# ifdef SINGLES
+ if (NIMP(last) && tc_dblr==CAR(last))
+# else
+ if (NIMP(last) && (last != flo0) && (tc_dblr==CAR(last)))
+# endif
+ {
+ REAL(last) = ((double *)CDR(v))[pos];
+ return last;
+ }
+# endif /* ndef CDR_DOUBLES */
+ return makdbl(((double *)CDR(v))[pos], 0.0);
+# endif /* def FLOATS */
+ case tc7_vector:
+ return VELTS(v)[pos];
+ case tc7_smob: { /* enclosed array */
+ int k = ARRAY_NDIM(v);
+ if (IMP(last) || (!ARRAYP(last))) {
+ last = make_ra(k);
+ ARRAY_V(last) = ARRAY_V(v);
+ while (k--) {
+ ARRAY_DIMS(last)[k].ubnd = ARRAY_DIMS(v)[k].ubnd;
+ ARRAY_DIMS(last)[k].lbnd = ARRAY_DIMS(v)[k].lbnd;
+ ARRAY_DIMS(last)[k].inc = ARRAY_DIMS(v)[k].inc;
+ }
+ }
+ ARRAY_BASE(last) = pos;
+ return last;
+ }
+ }
+}
+
+static char s_aset[] = "array-set!";
+SCM aset(v, obj, args)
+ SCM v, obj, args;
+{
+ long pos;
+ ASRTGO(NIMP(v), badarg1);
+ if ARRAYP(v) {
+ pos = aind(v, args, s_aset);
+ v = ARRAY_V(v);
+ }
+ else {
+ if NIMP(args) {
+ ASSERT(CONSP(args) && INUMP(CAR(args)), args, ARG2, s_aset);
+ pos = INUM(CAR(args));
+ ASRTGO(NULLP(CDR(args)), wna);
+ }
+ else {
+ ASSERT(INUMP(args), args, ARG2, s_aset);
+ pos = INUM(args);
+ }
+ ASRTGO(pos >= 0 && pos < LENGTH(v), outrng);
+ }
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_aset);
+ outrng: wta(MAKINUM(pos), (char *)OUTOFRANGE, s_aset);
+ wna: wta(UNDEFINED, (char *)WNA, s_aset);
+ case tc7_smob: /* enclosed */
+ goto badarg1;
+ case tc7_bvect:
+ if (BOOL_F==obj)
+ VELTS(v)[pos/LONG_BIT] &= ~(1L<<(pos%LONG_BIT));
+ else if (BOOL_T==obj)
+ VELTS(v)[pos/LONG_BIT] |= (1L<<(pos%LONG_BIT));
+ else badarg2: wta(obj, (char *)ARG2, s_aset);
+ break;
+ case tc7_string:
+ ASRTGO(ICHRP(obj), badarg2);
+ CHARS(v)[pos] = ICHR(obj); break;
+# ifdef INUMS_ONLY
+ case tc7_uvect:
+ ASRTGO(INUM(obj) >= 0, badarg2);
+ case tc7_ivect:
+ ASRTGO(INUMP(obj), badarg2); VELTS(v)[pos] = INUM(obj); break;
+# else
+ case tc7_uvect:
+ VELTS(v)[pos] = num2ulong(obj, (char *)ARG2, s_aset); break;
+ case tc7_ivect:
+ VELTS(v)[pos] = num2long(obj, (char *)ARG2, s_aset); break;
+# endif
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ ((float*)VELTS(v))[pos] = (float)num2dbl(obj, (char *)ARG2, s_aset); break;
+# endif
+ case tc7_dvect:
+ ((double*)VELTS(v))[pos] = num2dbl(obj, (char *)ARG2, s_aset); break;
+ case tc7_cvect:
+ if (NIMP(obj) && CPLXP(obj)) {
+ ((double *)CDR(v))[2*pos] = REALPART(obj);
+ ((double *)CDR(v))[2*pos+1] = IMAG(obj);
+ }
+ else {
+ ((double *)CDR(v))[2*pos] = num2dbl(obj, (char *)ARG2, s_aset);
+ ((double *)CDR(v))[2*pos+1] = 0.0;
+ }
+ break;
+# endif
+ case tc7_vector:
+ VELTS(v)[pos] = obj; break;
+ }
+ return UNSPECIFIED;
+}
+
+static char s_array_contents[] = "array-contents";
+SCM array_contents(ra, strict)
+ SCM ra, strict;
+{
+ SCM sra;
+ if IMP(ra) return BOOL_F;
+ switch TYP7(ra) {
+ default:
+ return BOOL_F;
+ case tc7_vector: case tc7_string: case tc7_bvect: case tc7_uvect:
+ case tc7_ivect: case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ return ra;
+ case tc7_smob: {
+ sizet k, ndim = ARRAY_NDIM(ra), len = 1;
+ if (!ARRAYP(ra) || !ARRAY_CONTP(ra)) return BOOL_F;
+ for (k = 0; k < ndim; k++)
+ len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
+ if (!UNBNDP(strict)) {
+ if (ndim && (1 != ARRAY_DIMS(ra)[ndim-1].inc)) return BOOL_F;
+ if (tc7_bvect==TYP7(ARRAY_V(ra))) {
+ if (ARRAY_BASE(ra)%LONG_BIT) return BOOL_F;
+ if (len != LENGTH(ARRAY_V(ra)) && len%LONG_BIT) return BOOL_F;
+ }
+ }
+ if ((len==LENGTH(ARRAY_V(ra))) && 0==ARRAY_BASE(ra) && ARRAY_DIMS(ra)->inc)
+ return ARRAY_V(ra);
+ sra = make_ra(1);
+ ARRAY_DIMS(sra)->lbnd = 0;
+ ARRAY_DIMS(sra)->ubnd = len - 1;
+ ARRAY_V(sra) = ARRAY_V(ra);
+ ARRAY_BASE(sra) = ARRAY_BASE(ra);
+ ARRAY_DIMS(sra)->inc = (ndim ? ARRAY_DIMS(ra)[ndim - 1].inc : 1);
+ return sra;
+ }
+ }
+}
+
+static char s_uve_rd[] = "uniform-vector-read!";
+SCM uve_read(v, port)
+ SCM v, port;
+{
+ long sz, len, ans;
+ long start=0;
+ if UNBNDP(port) port = cur_inp;
+ else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
+ ASRTGO(NIMP(v), badarg1);
+ len = LENGTH(v);
+ loop:
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_uve_rd);
+ case tc7_smob:
+ v = array_contents(v, BOOL_T);
+ ASRTGO(NIMP(v), badarg1);
+ if ARRAYP(v) {
+ array_dim *d = ARRAY_DIMS(v);
+ start = ARRAY_BASE(v);
+ len = d->inc * (d->ubnd - d->lbnd + 1);
+ v = ARRAY_V(v);
+ }
+ else
+ len = LENGTH(v);
+ goto loop;
+ case tc7_string:
+ sz = sizeof(char);
+ break;
+ case tc7_bvect:
+ len = (len+LONG_BIT-1)/LONG_BIT;
+ start /= LONG_BIT;
+ case tc7_uvect:
+ case tc7_ivect:
+ sz = sizeof(long);
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ sz = sizeof(float);
+ break;
+# endif
+ case tc7_dvect:
+ sz = sizeof(double);
+ break;
+ case tc7_cvect:
+ sz = 2*sizeof(double);
+ break;
+# endif
+ }
+ /* An ungetc before an fread will not work on some systems if setbuf(0).
+ do #define NOSETBUF in scmfig.h to fix this. */
+ if CRDYP(port) { /* UGGH!!! */
+ ungetc(CGETUN(port), STREAM(port));
+ CLRDY(port); /* Clear ungetted char */
+ }
+ SYSCALL(ans = fread(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port)););
+ if (TYP7(v)==tc7_bvect) ans *= LONG_BIT;
+ return MAKINUM(ans);
+}
+
+static char s_uve_wr[] = "uniform-vector-write";
+SCM uve_write(v, port)
+ SCM v, port;
+{
+ long sz, len, ans;
+ long start=0;
+ if UNBNDP(port) port = cur_outp;
+ else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
+ ASRTGO(NIMP(v), badarg1);
+ len = LENGTH(v);
+ loop:
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_uve_wr);
+ case tc7_smob:
+ v = array_contents(v, BOOL_T);
+ ASRTGO(NIMP(v), badarg1);
+ if ARRAYP(v) {
+ array_dim *d = ARRAY_DIMS(v);
+ start = ARRAY_BASE(v);
+ len = d->inc * (d->ubnd - d->lbnd + 1);
+ v = ARRAY_V(v);
+ }
+ else
+ len = LENGTH(v);
+ goto loop;
+ case tc7_string:
+ sz = sizeof(char);
+ break;
+ case tc7_bvect:
+ len = (len+LONG_BIT-1)/LONG_BIT;
+ start /= LONG_BIT;
+ case tc7_uvect:
+ case tc7_ivect:
+ sz = sizeof(long);
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ sz = sizeof(float);
+ break;
+# endif
+ case tc7_dvect:
+ sz = sizeof(double);
+ break;
+ case tc7_cvect:
+ sz = 2*sizeof(double);
+ break;
+# endif
+ }
+ SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port)););
+ if (TYP7(v)==tc7_bvect) ans *= LONG_BIT;
+ return MAKINUM(ans);
+}
+
+static char cnt_tab[16] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
+static char s_count[] = "bit-count";
+SCM lcount(item, seq)
+ SCM item, seq;
+{
+ long i, imin, ubnd, lbnd = 0;
+ int enclosed = 0;
+ register unsigned long cnt = 0, w;
+ ASSERT(NIMP(seq), seq, ARG2, s_count);
+ ubnd = LENGTH(seq) - 1;
+ tail:
+ switch TYP7(seq) {
+ default: badarg2: wta(seq, (char *)ARG2, s_count);
+ case tc7_bvect:
+ if (lbnd>ubnd) return INUM0;
+ i = ubnd/LONG_BIT;
+ imin = lbnd/LONG_BIT;
+ w = VELTS(seq)[i];
+ if FALSEP(item) w = ~w;
+ w <<= LONG_BIT-1-(ubnd%LONG_BIT);
+ w >>= LONG_BIT-1-(ubnd%LONG_BIT); /* There may be only a partial word. */
+ while (imin < i--) {
+ for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f];
+ w = VELTS(seq)[i];
+ if FALSEP(item) w = ~w;
+ }
+ w >>= (lbnd%LONG_BIT);
+ for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f];
+ return MAKINUM(cnt);
+ case tc7_smob:
+ ASRTGO(ARRAYP(seq) && 1==ARRAY_NDIM(seq) && 0==enclosed++, badarg2);
+ {
+ long n, inc = ARRAY_DIMS(seq)->inc;
+ switch (inc) {
+ default:
+ i = ARRAY_BASE(seq);
+ n = ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd + 1;
+ if (n<=0) return INUM0;
+ seq = ARRAY_V(seq);
+ if FALSEP(item)
+ for (;n--; i+=inc)
+ if (!((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT)))) cnt++;
+ else
+ for (;n--; i+=inc)
+ if ((VELTS(seq)[i/LONG_BIT]) & (1L<<(i%LONG_BIT))) cnt++;
+ return MAKINUM(cnt);
+ case 1:
+ lbnd = ARRAY_BASE(seq);
+ ubnd = lbnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc;
+ seq = ARRAY_V(seq);
+ goto tail;
+ case -1:
+ ubnd = ARRAY_BASE(seq);
+ lbnd = ubnd + (ARRAY_DIMS(seq)->ubnd - ARRAY_DIMS(seq)->lbnd)*inc;
+ seq = ARRAY_V(seq);
+ goto tail;
+ }
+ }
+ }
+}
+static char s_uve_pos[] = "bit-position";
+SCM position(item, v, k)
+ SCM item, v, k;
+{
+ long i, len, lenw, xbits, pos = INUM(k), offset = 0;
+ int enclosed = 0;
+ register unsigned long w;
+ ASSERT(NIMP(v), v, ARG2, s_uve_pos);
+ ASSERT(INUMP(k), k, ARG3, s_uve_pos);
+ len = LENGTH(v);
+ tail:
+ switch TYP7(v) {
+ default: badarg2: wta(v, (char *)ARG2, s_uve_pos);
+ case tc7_bvect:
+ ASSERT((pos <= len) && (pos >= 0), k, OUTOFRANGE, s_uve_pos);
+ if (pos==len) return BOOL_F;
+ if (0==len) return MAKINUM(-1L);
+ lenw = (len-1)/LONG_BIT; /* watch for part words */
+ i = pos/LONG_BIT;
+ w = VELTS(v)[i];
+ if FALSEP(item) w = ~w;
+ xbits = (pos%LONG_BIT);
+ pos -= xbits;
+ w = ((w >> xbits) << xbits);
+ xbits = LONG_BIT-1-(len-1)%LONG_BIT;
+ while (!0) {
+ if (w && (i==lenw))
+ w = ((w << xbits) >> xbits);
+ if (w) while (w) switch (w & 0x0f)
+ {
+ default: return MAKINUM(pos-offset);
+ case 2: case 6: case 10: case 14: return MAKINUM(pos+1-offset);
+ case 4: case 12: return MAKINUM(pos+2-offset);
+ case 8: return MAKINUM(pos+3-offset);
+ case 0: pos += 4; w >>= 4;
+ }
+ if (++i > lenw) break;
+ pos += LONG_BIT;
+ w = VELTS(v)[i];
+ if FALSEP(item) w = ~w;
+ }
+ return BOOL_F;
+ case tc7_smob: ASRTGO(ARRAYP(v) && 1==ARRAY_NDIM(v) && !enclosed++, badarg2);
+ ASSERT(pos >= ARRAY_DIMS(v)->lbnd, k, OUTOFRANGE, s_uve_pos);
+ if (1==ARRAY_DIMS(v)->inc) {
+ len = ARRAY_DIMS(v)->ubnd - ARRAY_DIMS(v)->lbnd + ARRAY_BASE(v) + 1;
+ offset = ARRAY_BASE(v) - ARRAY_DIMS(v)->lbnd;
+ pos += offset;
+ v = ARRAY_V(v);
+ goto tail;
+ }
+ else {
+ long inc = ARRAY_DIMS(v)->inc;
+ long ubnd = ARRAY_DIMS(v)->ubnd;
+ if (ubnd < ARRAY_DIMS(v)->lbnd)
+ return MAKINUM(ARRAY_DIMS(v)->lbnd - 1);
+ i = ARRAY_BASE(v) + (pos - ARRAY_DIMS(v)->lbnd)*inc;
+ v = ARRAY_V(v);
+ for (; pos <= ubnd; pos++) {
+ if (item ==
+ ((VELTS(v)[i/LONG_BIT])&(1L<<(i%LONG_BIT)) ? BOOL_T : BOOL_F))
+ return MAKINUM(pos);
+ i += inc;
+ }
+ return BOOL_F;
+ }
+ }
+}
+
+static char s_bit_set[] = "bit-set*!";
+SCM bit_set(v, kv, obj)
+ SCM v, kv, obj;
+{
+ register long i, k, vlen;
+ ASRTGO(NIMP(v), badarg1);
+ ASRTGO(NIMP(kv), badarg2);
+ switch TYP7(kv) {
+ default: badarg2: wta(kv, (char *)ARG2, s_bit_set);
+ case tc7_uvect:
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_bit_set);
+ case tc7_bvect:
+ vlen = LENGTH(v);
+ if (BOOL_F==obj) for (i = LENGTH(kv);i;) {
+ k = VELTS(kv)[--i];
+ ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
+ VELTS(v)[k/LONG_BIT] &= ~(1L<<(k%LONG_BIT));
+ }
+ else if (BOOL_T==obj) for (i = LENGTH(kv); i;) {
+ k = VELTS(kv)[--i];
+ ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_set);
+ VELTS(v)[k/LONG_BIT] |= (1L<<(k%LONG_BIT));
+ }
+ else
+ badarg3: wta(obj, (char *)ARG3, s_bit_set);
+ }
+ break;
+ case tc7_bvect:
+ ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1);
+ if (BOOL_F==obj)
+ for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;)
+ VELTS(v)[k] &= ~(VELTS(kv)[k]);
+ else if (BOOL_T==obj)
+ for (k = (LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;)
+ VELTS(v)[k] |= VELTS(kv)[k];
+ else goto badarg3;
+ break;
+ }
+ return UNSPECIFIED;
+}
+
+static char s_bit_count[] = "bit-count*";
+SCM bit_count(v, kv, obj)
+ SCM v, kv, obj;
+{
+ register long i, vlen, count = 0;
+ register unsigned long k;
+ ASRTGO(NIMP(v), badarg1);
+ ASRTGO(NIMP(kv), badarg2);
+ switch TYP7(kv) {
+ default: badarg2: wta(kv, (char *)ARG2, s_bit_count);
+ case tc7_uvect:
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_bit_count);
+ case tc7_bvect:
+ vlen = LENGTH(v);
+ if (BOOL_F==obj) for (i = LENGTH(kv);i;) {
+ k = VELTS(kv)[--i];
+ ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
+ if (!(VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT)))) count++;
+ }
+ else if (BOOL_T==obj) for (i = LENGTH(kv); i;) {
+ k = VELTS(kv)[--i];
+ ASSERT((k < vlen), MAKINUM(k), OUTOFRANGE, s_bit_count);
+ if (VELTS(v)[k/LONG_BIT] & (1L<<(k%LONG_BIT))) count++;
+ }
+ else
+ badarg3: wta(obj, (char *)ARG3, s_bit_count);
+ }
+ break;
+ case tc7_bvect:
+ ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v)==LENGTH(kv), badarg1);
+ if (0==LENGTH(v)) return INUM0;
+ ASRTGO(BOOL_T==obj || BOOL_F==obj, badarg3);
+ obj = (BOOL_T==obj);
+ i = (LENGTH(v)-1)/LONG_BIT;
+ k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]);
+ k <<= LONG_BIT-1-((LENGTH(v)-1)%LONG_BIT);
+ while (!0) {
+ for(;k;k >>= 4) count += cnt_tab[k & 0x0f];
+ if (0==i--) return MAKINUM(count);
+ k = VELTS(kv)[i] & (obj ? VELTS(v)[i] : ~VELTS(v)[i]);
+ }
+ }
+ return MAKINUM(count);
+}
+
+static char s_bit_inv[] = "bit-invert!";
+SCM bit_inv(v)
+ SCM v;
+{
+ register long k;
+ ASRTGO(NIMP(v), badarg1);
+ k = LENGTH(v);
+ switch TYP7(v) {
+ case tc7_bvect:
+ for (k = (k+LONG_BIT-1)/LONG_BIT;k--;)
+ VELTS(v)[k] = ~VELTS(v)[k];
+ break;
+ default: badarg1: wta(v, (char *)ARG1, s_bit_inv);
+ }
+ return UNSPECIFIED;
+}
+
+static char s_strup[] = "string-upcase!";
+SCM strup(v)
+ SCM v;
+{
+ register long k;
+ register unsigned char *cs;
+ ASRTGO(NIMP(v), badarg1);
+ k = LENGTH(v);
+ switch TYP7(v) {
+ case tc7_string:
+ cs = UCHARS(v);
+ while (k--) cs[k] = upcase[cs[k]];
+ break;
+ default: badarg1: wta(v, (char *)ARG1, s_strup);
+ }
+ return v;
+}
+
+static char s_strdown[] = "string-downcase!";
+SCM strdown(v)
+ SCM v;
+{
+ register long k;
+ register unsigned char *cs;
+ ASRTGO(NIMP(v), badarg1);
+ k = LENGTH(v);
+ switch TYP7(v) {
+ case tc7_string:
+ cs = UCHARS(v);
+ while (k--) cs[k] = downcase[cs[k]];
+ break;
+ default: badarg1: wta(v, (char *)ARG1, s_strdown);
+ }
+ return v;
+}
+
+# include <ctype.h>
+static char s_strcap[] = "string-capitalize!";
+SCM strcap(v)
+ SCM v;
+{
+ long i = 0, len;
+ register unsigned char *str;
+ register int non_first_alpha = 0;
+ ASRTGO(NIMP(v), badarg1);
+ len = LENGTH(v);
+ switch TYP7(v) {
+ case tc7_string:
+ for (str = UCHARS(v);i < len; i++) {
+ int c = str[i];
+ if (isascii(c) && isalpha(c))
+ if (non_first_alpha) str[i] = downcase[c];
+ else {
+ non_first_alpha = !0;
+ str[i] = upcase[c];
+ }
+ else non_first_alpha = 0;
+ }
+ break;
+ default: badarg1: wta(v, (char *)ARG1, s_strcap);
+ }
+ return v;
+}
+
+SCM istr2bve(str, len)
+ char *str;
+ long len;
+{
+ SCM v = make_uve(len, BOOL_T);
+ long *data = (long *)VELTS(v);
+ register unsigned long mask;
+ register long k;
+ register long j;
+ for (k = 0; k < (len+LONG_BIT-1)/LONG_BIT; k++) {
+ data[k] = 0L;
+ j = len - k*LONG_BIT;
+ if (j > LONG_BIT) j = LONG_BIT;
+ for (mask = 1L; j--; mask <<= 1)
+ switch (*str++) {
+ case '0': break;
+ case '1': data[k] |= mask; break;
+ default: return BOOL_F;
+ }
+ }
+ return v;
+}
+
+static SCM ra2l(ra, base, k)
+ SCM ra;
+ sizet base;
+ sizet k;
+{
+ register SCM res = EOL;
+ register long inc = ARRAY_DIMS(ra)[k].inc;
+ register sizet i;
+ if (ARRAY_DIMS(ra)[k].ubnd < ARRAY_DIMS(ra)[k].lbnd) return EOL;
+ i = base + (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd)*inc;
+ if (k < ARRAY_NDIM(ra) - 1) {
+ do {
+ i -= inc;
+ res = cons(ra2l(ra, i, k+1), res);
+ } while (i != base);
+ }
+ else
+ do {
+ i -= inc;
+ res = cons(cvref(ARRAY_V(ra), i, UNDEFINED), res);
+ } while (i != base);
+ return res;
+}
+
+static char s_array2list[] = "array->list";
+SCM array2list(v)
+ SCM v;
+{
+ SCM res = EOL;
+ register long k;
+ ASRTGO(NIMP(v), badarg1);
+ switch TYP7(v) {
+ default: badarg1: wta(v, (char *)ARG1, s_array2list);
+ case tc7_smob: ASRTGO(ARRAYP(v), badarg1);
+ return ra2l(v, ARRAY_BASE(v), 0);
+ case tc7_vector: return vector2list(v);
+ case tc7_string: return string2list(v);
+ case tc7_bvect: {
+ long *data = (long *)VELTS(v);
+ register unsigned long mask;
+ for (k = (LENGTH(v)-1)/LONG_BIT; k > 0; k--)
+ for (mask = 1L<<(LONG_BIT-1); mask; mask >>=1)
+ res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res);
+ for (mask = 1L<<((LENGTH(v)%LONG_BIT)-1); mask; mask >>=1)
+ res = cons(((long *)data)[k] & mask ? BOOL_T : BOOL_F, res);
+ return res;
+ }
+# ifdef INUMS_ONLY
+ case tc7_uvect:
+ case tc7_ivect: {
+ long *data = (long *)VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(MAKINUM(data[k]), res);
+ return res;
+ }
+# else
+ case tc7_uvect: {
+ long *data = (long *)VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(ulong2num(data[k]), res);
+ return res;
+ }
+ case tc7_ivect: {
+ long *data = (long *)VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(long2num(data[k]), res);
+ return res;
+ }
+# endif
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: {
+ float *data = (float *)VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(makflo(data[k]), res);
+ return res;
+ }
+# endif /*SINGLES*/
+ case tc7_dvect: {
+ double *data = (double *)VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(makdbl(data[k], 0.0), res);
+ return res;
+ }
+ case tc7_cvect: {
+ double (*data)[2] = (double (*)[2])VELTS(v);
+ for (k = LENGTH(v) - 1; k >= 0; k--)
+ res = cons(makdbl(data[k][0], data[k][1]), res);
+ return res;
+ }
+# endif /*FLOATS*/
+ }
+}
+
+static int l2ra P((SCM lst, SCM ra, sizet base, sizet k));
+static char s_bad_ralst[] = "Bad array contents list";
+static char s_list2ura[] = "list->uniform-array";
+SCM list2ura(ndim, prot, lst)
+ SCM ndim;
+ SCM prot;
+ SCM lst;
+{
+ SCM shp=EOL;
+ SCM row=lst;
+ SCM ra;
+ sizet k;
+ long n;
+ ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura);
+ k = INUM(ndim);
+ for (; k--; NIMP(row) && (row = CAR(row))) {
+ n = ilength(row);
+ ASSERT(n>=0, lst, ARG2, s_list2ura);
+ shp = cons(MAKINUM(n), shp);
+ }
+ ra = dims2ura(reverse(shp), prot, EOL);
+ if NULLP(shp) {
+ ASRTGO(1==ilength(lst), badlst);
+ aset(ra, CAR(lst), EOL);
+ return ra;
+ }
+ if (!ARRAYP(ra)) {
+ for (k = 0; k < LENGTH(ra); k++, lst = CDR(lst))
+ aset(ra, CAR(lst), MAKINUM(k));
+ return ra;
+ }
+ if (l2ra(lst, ra, ARRAY_BASE(ra), 0))
+ return ra;
+ else
+ badlst: wta(lst, s_bad_ralst, s_list2ura);
+ return BOOL_F;
+}
+
+static int l2ra(lst, ra, base, k)
+ SCM lst;
+ SCM ra;
+ sizet base;
+ sizet k;
+{
+ register long inc = ARRAY_DIMS(ra)[k].inc;
+ register long n = (1 + ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd);
+ int ok = 1;
+ if (n <= 0) return (EOL==lst);
+ if (k < ARRAY_NDIM(ra) - 1) {
+ while (n--) {
+ if (IMP(lst) || NCONSP(lst)) return 0;
+ ok = ok && l2ra(CAR(lst), ra, base, k+1);
+ base += inc;
+ lst = CDR(lst);
+ }
+ if NNULLP(lst) return 0;
+ }
+ else {
+ while (n--) {
+ if (IMP(lst) || NCONSP(lst)) return 0;
+ ok = ok && aset(ARRAY_V(ra), CAR(lst), MAKINUM(base));
+ base += inc;
+ lst = CDR(lst);
+ }
+ if NNULLP(lst) return 0;
+ }
+ return ok;
+}
+
+static void rapr1(ra, j, k, port, writing)
+ SCM ra;
+ sizet j;
+ sizet k;
+ SCM port;
+ int writing;
+{
+ long inc = 1;
+ long n = LENGTH(ra);
+ int enclosed = 0;
+ tail:
+ switch TYP7(ra) {
+ case tc7_smob:
+ if (enclosed++) {
+ ARRAY_BASE(ra) = j;
+ if (n-- > 0) iprin1(ra, port, writing);
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ ARRAY_BASE(ra) = j;
+ iprin1(ra, port, writing);
+ }
+ break;
+ }
+ if (k+1 < ARRAY_NDIM(ra)) {
+ long i;
+ inc = ARRAY_DIMS(ra)[k].inc;
+ for (i = ARRAY_DIMS(ra)[k].lbnd; i < ARRAY_DIMS(ra)[k].ubnd; i++) {
+ lputc('(', port);
+ rapr1(ra, j, k+1, port, writing);
+ lputs(") ", port);
+ j += inc;
+ }
+ if (i==ARRAY_DIMS(ra)[k].ubnd) { /* could be zero size. */
+ lputc('(', port);
+ rapr1(ra, j, k+1, port, writing);
+ lputc(')', port);
+ }
+ break;
+ }
+ if ARRAY_NDIM(ra) { /* Could be zero-dimensional */
+ inc = ARRAY_DIMS(ra)[k].inc;
+ n = (ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1);
+ }
+ else
+ n = 1;
+ ra = ARRAY_V(ra);
+ goto tail;
+ default:
+ if (n-- > 0) iprin1(cvref(ra, j, UNDEFINED), port, writing);
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ iprin1(cvref(ra, j, UNDEFINED), port, writing);
+ }
+ break;
+ case tc7_string:
+ if (n-- > 0) iprin1(MAKICHR(CHARS(ra)[j]), port, writing);
+ if (writing)
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ iprin1(MAKICHR(CHARS(ra)[j]), port, writing);
+ }
+ else
+ for (j += inc; n-- > 0; j += inc)
+ lputc(CHARS(ra)[j], port);
+ break;
+ case tc7_uvect:
+ if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ }
+ break;
+ case tc7_ivect:
+ if (n-- > 0) intprint(VELTS(ra)[j], 10, port);
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ intprint(VELTS(ra)[j], 10, port);
+ }
+ break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+# endif /*SINGLES*/
+ case tc7_dvect:
+ case tc7_cvect:
+ if (n-- > 0) {
+ SCM z = cvref(ra, j, UNDEFINED);
+ floprint(z, port, writing);
+ for (j += inc; n-- > 0; j += inc) {
+ lputc(' ', port);
+ z = cvref(ra, j, z);
+ floprint(z, port, writing);
+ }
+ }
+ break;
+# endif /*FLOATS*/
+ }
+}
+int raprin1(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ SCM v = exp;
+ sizet base = 0;
+ lputc('#', port);
+ tail:
+ switch TYP7(v) {
+ case tc7_smob: {
+ long ndim = ARRAY_NDIM(v);
+ base = ARRAY_BASE(v);
+ v = ARRAY_V(v);
+ if ARRAYP(v) {
+ lputs("<enclosed-array ", port);
+ rapr1(exp, base, 0, port, writing);
+ lputc('>', port);
+ return 1;
+ }
+ else {
+ intprint(ndim, 10, port);
+ goto tail;
+ }
+ }
+ case tc7_bvect:
+ if (exp==v) { /* a uve, not an array */
+ register long i, j, w;
+ lputc('*', port);
+ for(i = 0;i<(LENGTH(exp))/LONG_BIT;i++) {
+ w = VELTS(exp)[i];
+ for(j = LONG_BIT;j;j--) {
+ lputc(w&1?'1':'0', port);
+ w >>= 1;
+ }
+ }
+ j = LENGTH(exp)%LONG_BIT;
+ if (j) {
+ w = VELTS(exp)[LENGTH(exp)/LONG_BIT];
+ for(;j;j--) {
+ lputc(w&1?'1':'0', port);
+ w >>= 1;
+ }
+ }
+ return 1;
+ }
+ else
+ lputc('b', port); break;
+ case tc7_string:
+ lputc('a', port); break;
+ case tc7_uvect:
+ lputc('u', port); break;
+ case tc7_ivect:
+ lputc('e', port); break;
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect:
+ lputc('s', port); break;
+# endif /*SINGLES*/
+ case tc7_dvect:
+ lputc('i', port); break;
+ case tc7_cvect:
+ lputc('c', port); break;
+# endif /*FLOATS*/
+ }
+ lputc('(', port);
+ rapr1(exp, base, 0, port, writing);
+ lputc(')', port);
+ return 1;
+}
+
+static char s_array_prot[] = "array-prototype";
+SCM array_prot(ra)
+ SCM ra;
+{
+ int enclosed = 0;
+ ASRTGO(NIMP(ra), badarg);
+ loop:
+ switch TYP7(ra) {
+ default: badarg: wta(ra, (char *)ARG1, s_array_prot);
+ case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
+ if (enclosed++) return UNSPECIFIED;
+ ra = ARRAY_V(ra);
+ goto loop;
+ case tc7_vector: return EOL;
+ case tc7_bvect: return BOOL_T;
+ case tc7_string: return MAKICHR('a');
+ case tc7_uvect: return MAKINUM(1L);
+ case tc7_ivect: return MAKINUM(-1L);
+# ifdef FLOATS
+# ifdef SINGLES
+ case tc7_fvect: return makflo(1.0);
+# endif
+ case tc7_dvect: return makdbl(1.0/3.0, 0.0);
+ case tc7_cvect: return makdbl(0.0, 1.0);
+# endif
+ }
+}
+
+static iproc subr3s[] = {
+ {"uniform-vector-set1!", aset},
+ {s_uve_pos, position},
+ {s_bit_set, bit_set},
+ {s_bit_count, bit_count},
+ {s_list2ura, list2ura},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {"uniform-vector-ref", aref},
+ {s_resizuve, resizuve},
+ {s_count, lcount},
+ {s_uve_fill, uve_fill},
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {"array-rank", array_rank},
+ {s_array_dims, array_dims},
+ {s_array2list, array2list},
+ {s_uve_len, uve_len},
+ {s_bit_inv, bit_inv},
+ {s_strdown, strdown},
+ {s_strcap, strcap},
+ {s_strup, strup},
+ {s_array_prot, array_prot},
+ {0, 0}};
+
+static iproc lsubrs[] = {
+ {s_aref, scm_array_ref},
+ {s_trans_array, trans_array},
+ {s_encl_array, encl_array},
+ {s_array_inbp, array_inbp},
+ {0, 0}};
+
+static iproc lsubr2s[] = {
+ {s_make_sh_array, make_sh_array},
+ {s_dims2ura, dims2ura},
+ {s_aset, aset},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {"array?", arrayp},
+ {s_array_contents, array_contents},
+ {s_uve_rd, uve_read},
+ {s_uve_wr, uve_write},
+ {0, 0}};
+
+static SCM markra(ptr)
+ SCM ptr;
+{
+ if GC8MARKP(ptr) return BOOL_F;
+ SETGC8MARK(ptr);
+ return ARRAY_V(ptr);
+}
+static sizet freera(ptr)
+ CELLPTR ptr;
+{
+ must_free(CHARS(ptr));
+ return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim);
+}
+static smobfuns rasmob = {markra, freera, raprin1, 0};
+ /* 0 replaced by raequal in init_ramap() */
+
+/* This must be done after init_scl() */
+void init_unif()
+{
+ init_iprocs(subr3s, tc7_subr_3);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(lsubrs, tc7_lsubr);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ init_iprocs(subr2os, tc7_subr_2o);
+ tc16_array = newsmob(&rasmob);
+ add_feature(s_array);
+ add_feature("string-case");
+}
+
+#else /* ARRAYS */
+
+int raprin1(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ return 0;
+}
+
+SCM istr2bve(str, len)
+ char *str;
+ long len;
+{
+ return BOOL_F;
+}
+
+SCM array_equal(ra0, ra1)
+ SCM ra0, ra1;
+{
+ return BOOL_F;
+}
+
+void init_unif()
+{
+ make_subr(s_resizuve, tc7_subr_2, resizuve);
+}
+
+#endif /* ARRAYS */
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 <pwd.h>
+#include <sys/types.h>
+/* #include <sys/wait.h> */
+#include <sys/stat.h>
+
+SCM stat2scm P((struct stat *stat_temp));
+
+#ifndef STDC_HEADERS
+ void sync P((void));
+ int symlink P((const char *oldpath, const char *newpath));
+ int readlink P((const char *path, char *buf, sizet bufsiz));
+ int acct P((const char *filename));
+ int nice P((int inc));
+#endif /* STDC_HEADERS */
+
+ /* Only the superuser can successfully execute mknod and acct */
+/* int mknod P((const char *path, mode_t mode, dev_t dev));
+ should be in stat.h */
+static char s_mknod[] = "mknod";
+SCM l_mknod(path, mode, dev)
+ SCM path, mode, dev;
+{
+ int val;
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_mknod);
+ ASSERT(INUMP(mode), mode, ARG2, s_mknod);
+ ASSERT(INUMP(dev), dev, ARG3, s_mknod);
+ SYSCALL(val = mknod(CHARS(path), INUM(mode), INUM(dev)););
+ return val ? BOOL_F : BOOL_T;
+}
+static char s_acct[] = "acct";
+SCM l_acct(path)
+ SCM path;
+{
+ int val;
+ if FALSEP(path) {
+ SYSCALL(val = acct(0););
+ return val ? BOOL_F : BOOL_T;
+ }
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_acct);
+ SYSCALL(val = acct(CHARS(path)););
+ return val ? BOOL_F : BOOL_T;
+}
+
+static char s_nice[] = "nice";
+SCM l_nice(incr)
+ SCM incr;
+{
+ ASSERT(INUMP(incr), incr, ARG1, s_nice);
+ return nice(INUM(incr)) ? BOOL_F : BOOL_T;
+}
+
+SCM l_sync()
+{
+ sync();
+ return UNSPECIFIED;
+}
+
+static char s_symlink[] = "symlink";
+SCM l_symlink(oldpath, newpath)
+ SCM oldpath, newpath;
+{
+ int val;
+ ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_symlink);
+ ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_symlink);
+ SYSCALL(val = symlink(CHARS(oldpath), CHARS(newpath)););
+ return val ? BOOL_F : BOOL_T;
+}
+static char s_readlink[] = "readlink";
+SCM l_readlink(path)
+ SCM path;
+{
+ int i;
+ char buf[1024];
+ ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_readlink);
+ SYSCALL(i = readlink(CHARS(path), buf, (sizet)sizeof(buf)););
+ if (-1==i) return BOOL_F;
+ return makfromstr(buf, (sizet)i);
+}
+static char s_lstat[] = "lstat";
+SCM l_lstat(str)
+ SCM str;
+{
+ int i;
+ struct stat stat_temp;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_lstat);
+ SYSCALL(i = lstat(CHARS(str), &stat_temp););
+ if (i) return BOOL_F;
+ return stat2scm(&stat_temp);
+}
+
+static iproc subr1s[] = {
+ {s_nice, l_nice},
+ {s_acct, l_acct},
+ {s_lstat, l_lstat},
+ {s_readlink, l_readlink},
+ {0, 0}};
+
+void init_unix()
+{
+ make_subr("sync", tc7_subr_0, l_sync);
+ init_iprocs(subr1s, tc7_subr_1);
+ make_subr(s_symlink, tc7_subr_2, l_symlink);
+ make_subr(s_mknod, tc7_subr_3, l_mknod);
+ add_feature("unix");
+}