Import Upstream version 5d6upstream/5d6

77 files changed, 25690 insertions, 6600 deletions

diff --git a/.gdbinit b/.gdbinit
index 3bfc8e0..a1d20b0 100644
--- a/.gdbinit
+++ b/.gdbinit
@@ -15,26 +15,26 @@
 # the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 #
 # As a special exception, the Free Software Foundation gives permission
-# for additional uses of the text contained in its release of GUILE.
+# for additional uses of the text contained in its release of SCM.
 #
-# The exception is that, if you link the GUILE library with other files
+# The exception is that, if you link the SCM 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.
+# linking the SCM 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
+# Free Software Foundation under the name SCM.  If you copy
 # code from other Free Software Foundation releases into a copy of
-# GUILE, as the General Public License permits, the exception does
+# SCM, 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
+# If you write modifications of your own for SCM, it is your choice
 # whether to permit this exception to apply to your modifications.
 # If you do not wish that, delete this exception notice.  
 
@@ -64,6 +64,11 @@ define scm
   call newline(sys_protects[2]),(void)0
 end
 
+define code
+  call scm_princode($arg0, scm_estk_ptr[2], sys_protects[2], 1),(void)0
+  call newline(sys_protects[2]),(void)0
+end
+
 define lload
   if (errjmp_bad)
     echo sorry, errjmp_bad\n
diff --git a/ANNOUNCE b/ANNOUNCE
index 176bf90..062f2da 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -1,137 +1,31 @@
-This message announces the availability of Scheme release scm5d2.
-
-New in scm5d2:
-
-	* Makefile (install): Make sure $(libscmdir)require.scm exists.
-	(libscmdir): Use instead of IMPLPATH.
-	* repl.c (scm_top_level): Corrected error test on exit in case 0
-	is not success.
-	(repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive
-	session on EOF, this should not be an error.
-	* build.scm (define-compile-commands): Added.
-	(defcommand): Added.
-	(platform): formatted; simplified names.
-	* Makefile (features.txi): Added.
-	* scm.texi (Build Options): take feature documentation from
-	"features.txi".
-	* build (make-features-txi): Creates documentation of build
-	features from 'features table.
-	* build.scm (build:define-feature): Added.  Feature definitions
-	moved to top level.
-	* Init5d1.scm (comment): Added.
-	(read:sharp): Added `#;' comment syntax, *feature* SHARP:SEMI.
-	* sys.c (scm_env_v2lst): Made tolerant to argc of zero,
-	since ecache_evalx may call it thus for DO loops binding
-	no values.
-	* eval.c (debug_env_save): Function for use in ENV_SAVE when the
-	CAREFUL_INTS paranoid debugging flag is #defined.
-	(ecache_eval_args): Now calls ecache_evalx(), which
-	evaluates a list of expressions and returns a list allocated on
-	the ecache in scm_env_tmp.
-	(m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call
-	ecache_evalx instead of using inline loops, this seems to improve
-	speed by 5% - 10% for jacal and for simsynch simulation.  C stack
-	usage will increase somewhat for large env frames.
-	(lookupcar): Added support for constant bindings, to be created by
-	LET, LETREC, LET*.
-	* scl.c (dbl_prec): Use dbl_mant_dig in preference of potentially
-	undefined DBL_MANT_DIG.
-	* gmalloc.c: include "getpagesize.h" conditionalized on __svr4__.
-	* build.scm (batch:chop-to-fit-system): Removed.  Use new
-	batch:try-chopped-command instead.
-	(mysql): Added to features.
-	(build:build): Added comments describing stages and errors.
-	* Makefile: Added platform.txi dependency where dependent on
-	scm.texi.
-	* Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"?
-	* sys.c (mode_bits): Fix for null output string case.
-	* unif.c (make_sh_array): Reduced consing by using scm_cvapply
-	instead of apply.
-	*sys.c (mode_bits): Now takes an optional buffer which, on exit,
-	will hold a mode string suitable to pass to fopen(), without any
-	SCM extension characters.
-	* r4rstest.scm (float-print-test): stop after first error.
-	* sys.c (try_open_file): Insure that only 'r', 'w', 'b', or '+'
-	may be included in mode strings passed to fopen.
-	* repl.c (scm_freshline): Added FRESHLINE.
-	* sys.c (init_storage): Make def_outp tracked, so freshline will
-	work with it.
-	* ramap.c (cind): Now takes C vector of indices, which may be
-	allocated on the C stack, rather than a uve.
-	(ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe):
-	Use scm_cvapply instead of apply, allocate index and argument vectors
-	on the C stack for array ranks < 5.
-	* record.c (makrectyp): (recprin1): Use scm_cvapply instead of
-	apply.
-	(rec_prinset): Checks arity of argument procedure.
-	* sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of
-	apply.
-	(mksfpt): Checks arities of soft port procedures when the port is made.
-	* eval.c (scm_cvapply): (scm_arity_check): Exported.
-	(makacro): (makmacro): (makmmacro): Call scm_cvapply rather than
-	consing up argument lists.  Check arity of macro transformers
-	once, when syntax is defined.
-	* subr.c (make_vector): Fixed broken length argument test.
-	* sys.c (scm_env_v2lst): Now takes list tail in scm_env_tmp, so
-	tail can be allocated on ecache.
-	* repl.c (scm_top_level): Print out supplied program arguments for
-	failure exits to simplify debugging scripts.
-	* eval.c (varcheck): Fixed for RECKLESS case.
-	* eval.c (scm_arity_check): (macroexp1): Argument number checking
-	in macroexp1 abstracted as scm_arity_check, for use in map,
-	for-each ...
-	(scm_cvapply):  Apply a function to a C vector of arguments, used by
-	map and for-each.
-	(scm_v2lst):  Added for use in scm_cvapply.
-	(map): (for_each): Speed considerably improved: No longer allocate
-	Scheme vector temporaries for up to 5 list arguments.  No longer
-	allocate unnecessary argument lists, allocate on ecache if
-	possible.
-	* repl.c (iprin1): Print out first elt of cclo environment --
-	makes record procedures more identifiable.
-	* sys.c (scm_env_v2lst): Now takes last cdr of list as argument.
-	* sys.c (scm_port_entry): Make 16-bit safe.
-	* Tscript.scm: File added to implement transcript-on,
-	transcript-off without burdening normal i/o.
-	* Init5d1.scm (transcript-on): (transcript-off): Now autoloads
-	from SCM/Tscript.scm
-	(_TRACKED): Added.
-	* socket.c (l_socket): (l_connect): (l_listen): Modified to use
-	port table.
-	(l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not
-	just OPPORTP.
-	* posix.c (l_pipe): Modified to use port table.
-	(prinpipe): Removed.
-	* ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port
-	table.
-	* crs.c (prinwindow): Removed.
-	(mkwindow): Uses scm_port_entry.
-	* repl.c (iprin1): Uses "name" field for printing ports.
-	(input_waiting):  (wait_for_input):
-	(trans_on): (trans_off): Removed in favor of soft-port implementation.
-	(lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for
-	transcript, added line and column number support.  Unread char now
-	kept in port table rather than CAR.
-	(lreadpr): (line_num): Removed line counting for load port, now done
-	using general line and column counting.
-	(scm_port_line): (scm_port_column): (scm_port_filename): Added.
-	(err_head): Now prints out multiple filenames for nested loads.
-	Tries to recover from recursive errors if current-error-port is a
-	soft-port.
-	* unif.c (uve_read): Removed ungetc call, if there is an unread
-	character, just call lgetc repeatedly for the first elt.
-	* sys.c (must_malloc): (must_realloc): Now check whether the heap
-	is initialized or not, so may be called earlier.
-	(scm_init_gra): (scm_grow_gra):  Use above feature.
-	(scm_port_entry):  Added, allocates entry in a port table used to store
-	unread characters, file names, line & column numbers, &c.
-	(mark_port_table): (sweep_port_table): Gc support for port table.
-	ptobfuns now has a "name" element, used for printing.
-	(prinfport): (prinstpt): (prinsfpt):  Removed.
-
- From David Yeh:
-	* scl.c (makdbl): Mods to compile using MSVC.
-	* scmfig.h: Don't #define SINGLES for MSC.
+This message announces the availability of Scheme release scm5d6.
+
+New in scm5d6:
+
+From Aubrey Jaffer:
+
+ + Tanel Tammet's Hobbit compiler is now integrated into the SCM
+   distribution.
+
+ + hobbit.scm modified for (symbol) GC changes in SCM.  Use of
+   scm_gc_protect() instead of lists of protected objects means code
+   produced by Hobbit is smaller and more readable.
+
+ + Converted the hobbit documentation to texinfo format.
+   http://swissnet.ai.mit.edu/~jaffer/hobbit_toc.html
+
+From George Bronnikov:
+
+ + Ported SCM to the PLAN9 operating-system.
+
+From Martin Lafaix
+
+ + scm.c (l_raise, l_sleep):
+ + script.c (dld_find_executable):
+ + scmmain.c, scmfig.h: Ported to OS/2, IBM VisualAge C++ v3.
+
+Plus improvements and bug fixes too numerous to include here (see
+scm/ChangeLog).
 
 				-=-=-
 
@@ -147,51 +41,66 @@ include SCM in other programs.  Documentation is online at:
 	     http://swissnet.ai.mit.edu/~jaffer/SCM.html
 
 SCM source is available from:
- http://swissnet.ai.mit.edu/ftpdir/scm/scm5d2.zip
- ftp.gnu.org:pub/gnu/jacal/scm5d2.zip (FTP instructions follow)
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm5d6.zip
+ swissnet.ai.mit.edu:/pub/scm/scm5d6.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.src.rpm
+ swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.src.rpm
+Also available as i386 binary RPM:
+ http://swissnet.ai.mit.edu/ftpdir/scm/scm-5d6-1.i386.rpm
+ swissnet.ai.mit.edu:/pub/scm/scm-5d6-1.i386.rpm
 
 SLIB is a portable Scheme library which SCM uses:
- http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip
- ftp.gnu.org:pub/gnu/jacal/slib2c7.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip
+ swissnet.ai.mit.edu:/pub/scm/slib2d4.zip
+Also available as RPM:
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d4-1.noarch.rpm
+ swissnet.ai.mit.edu:/pub/scm/slib-2d4-1.noarch.rpm
 
 JACAL is a symbolic math system written in Scheme:
- http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b0.zip
- ftp.gnu.org:pub/gnu/jacal/jacal1b0.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/jacal1b2.zip
+ swissnet.ai.mit.edu:/pub/scm/jacal1b2.zip
 
 HOBBIT is a compiler for SCM code:
  http://swissnet.ai.mit.edu/ftpdir/scm/hobbit5x.tar.gz
- ftp.gnu.org:pub/gnu/jacal/hobbit5x.tar.gz
+ swissnet.ai.mit.edu:/pub/scm/hobbit5x.tar.gz
 
 SLIB-PSD is a portable debugger for Scheme (requires emacs editor):
  http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz
- ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz
+ swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz
 
 SMG-SCM is an SMG interface package which works with SCM on VMS.
  http://swissnet.ai.mit.edu/ftpdir/scm/smg-scm2a1.zip
- ftp.gnu.org:pub/gnu/jacal/smg-scm2a1.zip
+ swissnet.ai.mit.edu:/pub/scm/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:
  http://swissnet.ai.mit.edu/ftpdir/scm/turtlegr.tar.gz
- ftp.gnu.org:pub/gnu/jacal/turtlegr.tar.gz
+ swissnet.ai.mit.edu:/pub/scm/turtlegr.tar.gz
 
 XSCM is a X windows interface package which works with SCM:
  http://swissnet.ai.mit.edu/ftpdir/scm/xscm-2.01.tar.gz
- ftp.gnu.org:pub/gnu/jacal/xscm-2.01.tar.gz
+ swissnet.ai.mit.edu:/pub/scm/xscm-2.01.tar.gz
 
 MacSCM is a Macintosh applications building package which works with
 SCM (similar to XSCM).
  http://swissnet.ai.mit.edu/ftpdir/scm/macscm.tar.Z
+ swissnet.ai.mit.edu:/pub/scm/macscm.tar.Z
 
 WB is a disk based, sorted associative array (B-tree) library for SCM.
 Using WB, large databases can be created and managed from SCM.
- http://swissnet.ai.mit.edu/ftpdir/scm/wb1a2.tar.gz
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb1a7.zip
+ swissnet.ai.mit.edu:/pub/scm/wb1a7.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.src.rpm
+ swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.src.rpm
+Also available as i386 binary RPM:
+ http://swissnet.ai.mit.edu/ftpdir/scm/wb-1a7-1.i386.rpm
+ swissnet.ai.mit.edu:/pub/scm/wb-1a7-1.i386.rpm
 
 SIMSYNCH is a digital logic simulation system written in SCM.
  http://swissnet.ai.mit.edu/ftpdir/scm/synch1b0.zip
- ftp.gnu.org:pub/gnu/jacal/synch1b0.zip
+ swissnet.ai.mit.edu:/pub/scm/synch1b0.zip
 
 DLD is a C library package allowing SCM to dynamically load object
 files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation
@@ -199,22 +108,17 @@ files on VAX (Ultrix), Sun 3 (SunOS 3.4 and 4.0), SPARCstation
 systems.
  ftp.gnu.org:pub/gnu/dld/dld-3.3.tar.gz
 
-SCM.EXE (265k) is a SCM executable for DOS and MS-Windows.
-Note: SCM.EXE still requires slib2c7 and scm5d2 above.
+SCM.EXE (282k) is a SCM executable for DOS and MS-Windows.
+Note: SCM.EXE still requires slib2d4 and scm5d6 above.
  http://swissnet.ai.mit.edu/ftpdir/scm/scm.exe
+ swissnet.ai.mit.edu:/pub/scm/scm.exe
 
 #! implements "#!" (POSIX) shell-scripts for MS-DOS batch files.
  http://swissnet.ai.mit.edu/ftpdir/scm/sharpbang.zip
+ swissnet.ai.mit.edu:/pub/scm/sharpbang.zip
  http://swissnet.ai.mit.edu/ftpdir/scm/#!.zip
+ swissnet.ai.mit.edu:/pub/scm/#!.zip
 
 Programs for printing and viewing TexInfo documentation (which SCM
 has) come with GNU Emacs or can be obtained via ftp from:
  ftp.gnu.org:pub/gnu/texinfo/texinfo-4.0.tar.gz
-
-				-=-=-
-
-  ftp ftp.gnu.org (anonymous)
-  bin
-  cd pub/gnu/jacal
-  get slib2c7.zip
-  get scm5d2.zip
diff --git a/ChangeLog b/ChangeLog
index 56ca861..6b10d92 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,1358 @@
-Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+2002-04-14  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+
+	* patchlvl.h (SCMVERSION): Bumped from 5d5 to 5d6.
+
+	* build.scm (platform->os): Added.
+
+2002-04-11  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.texi (Invoking Build): Updated script examples.  Changed vms
+	example to darwin.
+
+	* Makefile (CITERS): Added hobbit.scm.
+	(CC): Commented out "CC = gcc".
+
+2002-04-11  Tanel Tammet <tammet@staff.ttu.ee>
+
+	* hobbit.scm (verbose): compilation corrected.
+	(require): moved from top level to hobbit procedure.
+	(copy-tree, acons, system): compilation introduced.
+
+2002-04-08  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* compile.scm (compile->executable): Removed gratuitous "-cscm.c".
+
+	* scm.c (SYSTNAME): __MACH__ was causing conflicting #define.
+	__MACH__ is "unix".
+
+2002-04-07  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scl.c (subr1s, subr2s): Corrected conditioning for
+	scm_make_dfloat, scm_next_dfloat, and scm_dfloat_parts.
+
+	* scm.c (LACK_RAISE): Cleaned up conditional tree for l_raise.
+
+	* repl.c (kbhit): #define to 0 for PLAN9.
+
+	* sys.c: PLAN9 needed fwrite() prototype.
+	(mark_finalizers): Was wrongly conditioned on !NO_SYM_GC.
+
+	* mkimpcat.scm (build): Changed to load "build" (sans ".scm").
+
+	* hobbit.texi (Compiling And Linking): Added examples for
+	compile-file and compile->executable.
+
+	* compile.scm (compile->executable): Replaces link-named-scm.
+
+2002-04-05    <aj@cypress.com>
+
+	* scmfig.h (STDC_HEADERS): Corrected PLAN9 typo.
+	(sizet): Corrected for PLAN9.
+
+2002-04-03  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c, time.c, continue.h, findexec.c, repl.c, scmfig.h, scm.h:
+	Ported to PLAN9.
+
+	* build.scm (plan9-8): Added port for Intel running PLAN9.
+	Comments desribe PLAN9 native C compiler `8c' options.
+
+2002-04-03  George Bronnikov <goga@rubinstein.mccme.ru>
+
+	* scm.c (raise, system, isatty): Added for PLAN9 port.
+
+2002-03-30  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d5.scm (vicinity:suffix?, set-vicinities!): Added PLAN9.
+	Cleaned archaic conditional defines.
+	(set-vicinities!): Moved to just before load of require.scm.
+
+	* requires.scm (PLAN9): Added support.
+
+2002-03-28  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* hobbit.texi: Changed most inline code snippets to @example.
+
+2002-03-28  Martin Lafaix <lafaix@online.fr>
+
+	* scm.c (l_raise, l_sleep):
+	* script.c (dld_find_executable):
+	* scmmain.c, scmfig.h: Ported to OS/2, IBM VisualAge C++ v3.
+
+2002-03-22    <aj@cypress.com>
+
+	* build.scm (C-libraries): Fixed dlll svr4-gcc-sun-ld.
+
+2002-03-21  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* hobbit.scm (every1): Renamed from EVERY.  Hobbit self-compile
+	chokes on multi-arg EVERY, complaining of non-liftable lambdaterm.
+
+2002-03-19  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* build.scm (make-dll-archive gcc): Was mistakenly labeled sunos.
+
+2002-03-10  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (hobbit.texi): Moved from hobfiles to dfiles.
+
+	* scm.spec (%files, %post): Added hobbit.
+
+	* hobbit.texi: Reorganization to chapter/section structure.
+	(Benchmarks): Shuffled so source not broken over dvi and pdf page
+	boundaries.
+
+	* Makefile (Xlibscm.pdf, hobbit.pdf): Targets added.
+
+2002-03-05  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scl.c (istr2int, in2ex): Conditioned HP700 workaround on hpux.
+
+	* r4rstest.scm (SECTION 6 5 9): Added 32-bit corner cases.
+
+	* hobbit.texi (Compiling And Linking): Moved from "scm.texi".
+
+2002-03-04  Radey Shouman  <shouman@ne.mediaone.net>
+
+	* scl.c (ist2int): Fix integer overflow bug for fixnum-only case.
+	eg: (string->number "80000000" 16) ==> 0
+
+2002-03-03  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* hobbit.texi: Converted to texinfo from plaintext hobbit.doc.
+
+	* unif.c (bit_position): Renamed from position.
+
+	* eval.c (scm_cp_list): Renamed from copy_list to avoid hobbit
+	conflict.
+
+	* Link.scm (file->init_name): Added to map "-" ==> "_".
+
+	* hobbit.scm (scm-gc-protect): Wraps replace protect-constant.
+	(*c-keywords*): Added names from "sc2.c".
+
+	* Init5d5.scm (hobbit.tms): Removed dependence on missing file.
+
+	* mkimpcat.scm: Reorganized more compactly.
+	(compile): Added feature.
+
+	* build.scm (manifest): Added "compile.scm".
+
+	* compile.scm (scm): For script to compile inexacts.
+	(hobbit, compile-file, link-named-scm): Extracted from Link.scm.
+	Require 'compile to use.
+
+	* rope.c (scm_gc_protect): Always return argument.
+
+	* xgen.scm (progname): Added so works when loaded (vs. script).
+	(xatoms): Read XcmsColorFormat value as two hex integers so SCMLIT
+	doesn't truncate 32-bit value.
+
+	* xatoms.scm (X:RGB): Corrected (SCMLIT truncated 32-bit value).
+	(X:RGBi): Added.
+
+	* Makefile (ifiles): Added "compile.scm".
+	(xevent.scm, xatoms.scm): Added aliases for xevent.h.
+
+2002-02-28  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d5.scm (*features*): Moved forward in file.
+
+	* scm.c (scm_init_INITS): Added.
+
+	* repl.c (scm_top_level): Added call to scm_init_INITS().
+
+	* build.scm (turtlegr, mysql): Changed to compiled-init.
+
+	* Makefile (udscm5): Removed "-l debug".
+	(BUILD): Abstracted ./build -hsystem -p WHATEVER.
+
+	* rope.c (scm_gc_protect): Don't bother protecting IMPs.
+
+	* hobbit.scm (file-exists?): Removed.
+	comlist.scm functions moved to end; names corrected.
+	(*constant-list-var*): Removed; replaced with calls to
+	scm_gc_protect.
+	(*filter-inside-term-res*, filter-inside-term-aux!): Moved inside
+	filter-inside-term.
+	(nth-cdr, split): Unused; removed.
+	(first-n-reverse): Moved inside only use: make-tailrec-call.
+	(headerline, *h-port*): Moved inside display-header.
+	(build-wrapper-aux, build-wrapper): Moved inside build-wrappers.
+	(my-last-pair-aux): Moved inside my-last-pair.
+
+	* Link.scm (link:link): Fixed prepending "./" for SUN-DL.
+
+2002-02-26  Radey Shouman  <shouman@ne.mediaone.net>
+
+	* eval.c (scm_cvapply): Removed PUSH_TRACE and POP_TRACE, which
+	were #ifdeffed out.  Testing with a version that pushed temporary
+	values on the C stack showed little to gain.
+
+2002-02-25  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* hobbit.scm (neq?): Inlined; removed.
+	(make-list, some): Rename egregious conflicts with SLIB, comlist.
+	(butlast): Changed to 2 argument function.
+
+	* Makefile (TAGFILES): build.scm was tagged twice.
+
+	* Link.scm (compile-file): Fixed suffix substitution.
+
+2002-02-23  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c (sysintern): Use scm_gc_protect().
+
+	* scm.h (scm_uprotects): Added to sys_protects[].
+
+	* scm.c (init_scm): Added init_rope() call.
+
+	* rope.c (scm_gc_protect, init_rope): Added.
+
+2002-02-17  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c (mark_subrs): Renamed from mark_subr_table.
+	(gra_report): Report both alloclen and len.
+	(init_types): scm.exe uses 397; always init malloc 420 subrs.
+	(scm_trim_gra): Added to downsize after init.
+
+	* scm.h (subrs_gra): Renamed from subr_table_gra.
+
+	* scm.c (scm_init_extensions): scm_trim_gra() ifndef HAVE_DYNL.
+
+2002-02-14  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* inc2scm, xgen.scm (go-script): Run even if not *script*.
+
+	* Makefile (CPROTO): Moved to srcdir.mk.
+	(x.h): Only create with $(CPROTO) if $(CPROTO) exists.
+	(x11.scm, keysymdef.scm, xevent.h, x.h): Don't use #!.
+
+2002-02-13  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (PREVDOCS): Changed to prevdocs/
+
+2002-02-11  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* patchlvl.h (SCMVERSION): Bumped from 5d4 to 5d5.
+
+	* sys.c (init_types): Initial subr_table size depends on
+	SHORT_SIZET.
+
+2002-02-10  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (CITERS, TAGFILES): Abstracted functional file groups.
+
+	* debug.c (stacktrace1): call to intprint() need long cast.
+
+	* rope.c: No longer include "continue.h".
+
+	* scmfig.h (PTR_GT, PTR_LE, PTR_GE): Put near PTR_LT.
+
+	* sys.c (heap_report): Moved from "repl.c".
+
+	* eval.c (scm_check_linum): Most calls to needed 0L.
+
+	* repl.c (everr): Call to scm_check_linum needed 0L.
+
+	* scm.texi (Allocating memory): must_realloc_cell, must_realloc
+	disallowed during init.
+
+	* sys.c (gra_report): Added.
+	(scm_gc_protect): Removed.
+	(init_types): Initialize sys_protects to UNDEFINED.
+	(init_types): Increased initial *_gra limits to prevent realloc
+	during init.
+	(must_realloc_cell, must_realloc): ASSERT !errjmp_bad.
+
+	* repl.c (lroom): Call gra_report().
+
+	* scm.h (flo0, NUM_PROTECTS): Don't #ifdef to save 4 bytes.
+	(f_apply_closure, eval_env, list_unspecified, f_evapply): In
+	sys_protects[].
+
+	* eval.c (init_eval): Removed calls to scm_gc_protect; put them in
+	sys_protects[].
+
+2002-02-08  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* eval.c (init_eval): eval_env assignment uses sysintern for INTS
+	discipline.
+
+	* sys.c (scm_estk_grow, scm_estk_shrink): +0L.
+	(mksafeport): Only called from init_storage(); don't DEFER_INTS.
+	(sysintern, scm_grow_gra): Only called while protected; don't
+	DEFER_INTS.
+	(scm_port_entry): Move malloc to init_storage().
+	(init_storage): Inlined creation of null string and vector; fixed
+	INTS discipline.
+
+	* scm.c (*scm-version*): Value changed to ssymbol for INTS
+	discipline.
+
+2002-02-06  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c (scm_open_ports, sysintern): Removed gratuitous casts.
+
+	* scm.c (init_scm): Changed order of init_*s.
+
+	* subr.c (mkbig): Removed gratuitous cast.
+
+	* unif.c (resizuve): Removed gratuitous cast.
+
+2002-02-03  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c (scm_grow_gra): Don't DEFER_INTS; only called from inits.
+	(scm_estk_shrink): Cast sizet passed to make_stk_seg().
+
+	* eval.c: Cleanup; made __LINE__ numbers int.
+
+	* scmmain.c (main): freeall is always 1.
+
+	* scmfig.h (ints_infot): linum long->int.
+
+	* scl.c (inex_divbigbig): Added default case.
+
+	* scm.texi (Memory Management for Environments): Added indexes.
+
+2002-02-02  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* posix.c (l_pipe): DEFER_INTS was missing.
+
+	* eval.c (init_eval): Cast argument to intern().
+
+	* repl.c (scm_top_level): Removed unreachable code.
+
+	* sys.c (scm_estk_shrink): Removed unused SCM *v.
+
+2002-01-31  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.texi (Uniform Array): Updated for SLIB changes.
+
+	* unif.c (float_eq_double_P, i_short): Removed.
+	(scm_prot2type): Removed most legacy prototypes; much simpler!
+
+	* Init5d4.scm (make-uniform-wrapper): Get rank correct.
+	(read:array): Use orthogonal prototypes for legacy syntax.
+
+	* ramap.c (array-indexes): Change to use create-array.
+
+	* Init5d4.scm (Ac64, Ac32, Ar64, Ar32, As64, As32, As16, As8,
+	Au64, Au32, Au16, Au8, At1): Added prototype makers.
+
+2002-01-29  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* debug.c (num_frames, estk_frame, cont_frame, stacktrace1):
+	Removed "static"; moved prototypes to scm.h.
+
+2002-01-28  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (macroexp1): Fix error handling for line-numbered objects
+	other than pairs.
+
+	* repl.c (lread_rec): Add line numbers to vectors read using
+	READ-NUMBERED, to allow more specific unquoted vector warnings.
+
+	* Init5d4.scm (read:sharp-char): Make #\C-M-a equivalent to #\M-C-a.
+
+2002-01-28  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.texi (Uniform Array): Removed most uniform-vector functions.
+
+	* Init5d4.scm: Removed uniform-vector functions.
+
+	* unif.c (uve_len, uniform-vector-length): Removed.
+	(uniform-vector-set1!, uniform-vector-ref): Removed.
+	(scm_prot2type, array_prot): Converted to new prototypes.
+
+	* unif.c (raprin1): Changed to new array syntax.
+
+	* Init5d4.scm (read:sharp-char): Rearranged.
+	(read:array): Support new array syntax.
+
+2002-01-26  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (call-with-open-ports): Accept arguments reversed.
+	(try-create-file): Accept symbol for modes argument.
+	(OPEN_READ, OPEN_WRITE, OPEN_BOTH): Changed to symbols.
+	(_IONBF, _TRACKED, _EXCLUSIVE): Work with strings OR symbols.
+
+	* ioext.c (reopen_file, l_dup2, scm_try_create_file):
+	* sys.c (mksfpt, try_open_file):
+	* posix.c (open_pipe): Accept symbol for modes argument.
+
+	* scm.texi (tc7_svect): Uniform short vector type.
+
+2002-01-24  Radey Shouman  <shouman@ne.mediaone.net>
+
+	* scm.c (l_sleep): Microsoft Sleep takes millisecond argument,
+	convert from seconds.
+
+	* repl.c (scm_err_line): Added for standard printing of erring
+	file and line number.
+	(err_head): Use scm_err_line.
+
+	* debug.c (princlosure, scm_scope_trace): Use scm_err_line.
+
+	* findexec.c: Do nothing if __MINGW32__ is #defined, so scmlit can
+	be built with mingw using the makefile.
+
+2002-01-22  Radey Shouman  <shouman@ne.mediaone.net>
+
+	* eval.c: (scm_cvapply, apply): Save and restore scm_trace
+	expression for better backtraces.
+	(map, for_each): No longer need additional tracing.
+
+	* debug.c: (stacktrace1): Use BOOL_F as default value of trace, to
+	avoid confusion with the UNDEFINED end-of-estk marker.
+
+2002-01-22  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* ioext.c, time.c, scm.c, findexec.c (__MACH__): Darwin port.
+
+	* build.scm (Darwin): Added support for APPLE/MACH/PPC.
+
+	* repl.c (swapcar): Added synchronization primitive.
+
+	* scm.texi (Process Synchronization): Added make-exchanger.
+
+	* Init5d4.scm (make-exchanger): Defined using swap-car!.
+
+2002-01-20  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* xgen.scm: QASE renamed from CASEV.
+
+	* Init5d4.scm, scm.texi (qase): Renamed from casev.
+	Feature `database-utilities' renamed `databases'.
+
+	* build.scm: Feature `database-utilities' renamed `databases'.
+
+2002-01-19  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (intro): Moved above srcdir.hk.  Added "make scm".
+
+2002-01-18  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* ramap.c (racp): Fixed bug in array-copy! from a general array to
+	a bit-array or a char-array.
+
+2002-01-15  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scmfig.h: Added MSVC pragmas.
+
+	* unif.c (raprin1): Fixed #Aid array prefix.
+	(float_eq_double_P): Added workaround for MSVC.
+
+2002-01-13  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (scm): Added just-bignums-and-arrays target for JACAL.
+
+	* Init5d4.scm (set-vicinities!): Load "requires.scm" if
+	"require.scm" absent.
+
+	* scm.c (SYSTNAME): __MACH__ -> "mach".
+
+	* scm.texi (Automatic C Preprocessor Definitions): Updated with
+	Apple Darwin flags.
+
+2002-01-03  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (array=?): Added.
+
+2001-12-06  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (scm.info): Depends on rautil.txi.
+
+2001-12-01  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (logical): Removed legacy definitions.
+
+	* r4rstest.scm (4 2 2): Added test for LET bug.
+
+2001-11-15  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* build.scm (build): Updated for SLIB dbutil changes.
+
+2001-11-11  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (bit-reverse integer->list list->integer
+	booleans->integer bitwise:laminate bitwise:delaminate): Added bit
+	order and lamination functions.
+
+	(integer->gray-code gray-code->integer gray-code<?  gray-code<=?
+	gray-code>?  gray-code>=?): Added Gray code functions.
+
+2001-10-27  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (gc_start, gc_end): Removed check for FPORTP(cur_errp),
+	no longer useful since we now write to sys_errp with no real
+	output until gc is over.
+
+2001-10-21  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* build (build-from-argv): Fail gracefully if params is #f.
+
+2001-09-27  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* ioext.c (file-exists?): Defined using ACCESS.
+	(scm_try_create_file): Conditional on O_EXCL being defined.
+
+2001-09-26  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (_EXCLUSIVE): Added.
+	(try-create-file): Added; supports open for exclusive write.
+	(file-exists?): Conditionally defined.
+
+	* ioext.c (scm_try_create_file): Moved from "unix.c".
+
+2001-09-24  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.texi (SCM Session): boot-tail documented.
+
+2001-09-21  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* bench.scm (benchmark): Metric interchange units.
+
+2001-09-11  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* xgen.scm (schemeify-name): Converted to use StudlyCapsExpand.
+
+	* Init5d4.scm (string-case): Added StudlyCapsExpand.
+
+2001-09-10  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* unix.c: (scm_try_create_file): Opens a file only if it does not
+	already exist.  (Uses open() with the O_EXCL flag).
+
+	* sys.c: (try_open_file): Calls back to try-create-file if an "x"
+	flag is specified.
+
+	* Init5d4.scm: (try-create-file): autoloaded.
+
+2001-09-03  Igor Goldenberg  <igold@mail.ru>
+
+	* findexec.c, scmfig.h, scm.c, time.c (__amigaos__): replaces
+	obsolete __amigados__.
+
+	* build.scm (amiga-gcc): "-O2" option removed (executable fails).
+
+2001-09-02  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.texi (SCM Options): Added "-r*rs" options.
+
+	* mkimpcat.scm (2rs, 3rs, 4rs, 5rs): Added aliases to make
+	"-r2rs".."-r5rs" command-line options work.
+
+	* Init5d4.scm (*syntax-rules*): Renamed from *R4RS-MACROS*.
+
+2001-09-01  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d4.scm (boot-tail): Converted -r2, -r3, -r4, and -r5
+	options to use r2rs, r3rs, r4rs, and r5rs features added to SLIB.
+
+	* Makefile (scmlit): 'rm slibcat implcat' *after* compilation.
+
+2001-08-31  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* scm.c, scmfig.h, script.c, time.c: Changed unix flags to
+	HAVE_UNIX.
+
+2001-08-31  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (m_expand_body, macroexp1): Try harder to keep non-memoizing
+	macros unmemoized.
+
+	* repl.c (scm_io_error): Now returns non-zero if EINTR seen.
+	(lfflush, lflush, lputc, lputs, lfwrite): No longer use
+	SYSCALL, but leave checking for EINTR to scm_io_error -- errno
+	need not be checked or set until an erring return value is seen.
+	(scm_warn): Now takes a scheme object to be printed as third argument.
+
+2001-08-30  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* sys.c (scm_port_entry): Now accepts a stream argument and
+	allocates the port cell.  Puts a back pointer (not a gc protect)
+	into the port table, for introspection.
+	(open-ports): Returns a list of open ports.  Should be useful for
+	fork, and maybe dump.
+	(port-type): Describes a port.
+
+	* crs.c ioext.c posix.c scm.h socket.c  Use new scm_port_entry call.
+
+	* ioext.c (ldup): Better error reporting for invalid mode flags.
+
+2001-08-27  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (scm_arity_check): Always return false for negative argc.
+	(macroexp1): Better error message for malformed expressions.
+
+2001-08-26  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (lungetc): Calls ungetc function if provided, this allows
+	string ports to work without using up port table entries.
+
+	* sys.c (stclose): Allows gc of string.
+		(stungetc): ungetc for string ports.
+
+2001-08-24  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c: (scm_io_error): Added BROKEN-PIPE callback.
+
+	* eval.c (m_case): Added callback to @case-aux to check for CASEs
+	that can be optimized to jump tables.
+
+	* Init5d4.scm (@case-aux): Definition added.
+
+2001-08-23  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* scmfig.h eval.c record.c rgx.c sys.c unif.c
+	(SCM2PTR, PTR2SCM): Added test definition, so we can verify that
+	the code still works.  Flushed out two actual bugs in eval.c.
+
+2001-08-16  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (m_case): CASE speed tweak.
+	(scm_case_selector): Added auxiliary function for CASE runtime.
+
+	*  sys.c (scm_gc_protect): Added to simplify eval.c.
+
+2001-08-15  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Link.scm (link:link): Load main file last for sun-dl.
+
+2001-08-13  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (NO_ENV_CACHE): option bitrot fixed.
+	(scm_v2lst): Now takes third argument for compatibility with
+	scm_env_v2lst.
+
+	* sys.c (scm_env_v2lst): Length argument now long instead of int
+	for compatibility with scm_v2lst.
+
+2001-08-11  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* dynl.c: DLOPEN_MODE now uses RTLD_GLOBAL iff it is #defined,
+	Linux (at least) requires it in order to stack compiled modules.
+	Also use RTLD_NOW, which allows reporting errors at load time,
+	rather than crashing the program when an undefined symbol is accessed.
+
+2001-08-09  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* mkimpcat.scm (add-link): Support symbols (features) in list.
+	(unix): Uses this feature.
+
+	* Init5d4.scm (slib:load-compiled): Require any symbols in list.
+
+	* Link.scm (link:link): Run 'init_<file>' only for first object
+	file.
+
+2001-07-30  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c: (err_head): Make sure cur_outp is open before fflushing it.
+	* sys.c: (clptob): Make flushing a closed port raise an error.
+
+2001-07-27  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* sys.c: (mode_bits, try_open_file, mksfpt):
+	* ioext.c: (reopen_file, l_dup):
+	Improved error checking for mode strings.
+
+2001-07-24  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (scm_io_error, lflush, lwrite, display, newline,
+	write_char, scm_freshline): Common code checking for EPIPE after
+	file errors, now prints warning before closing port.
+
+	* ioext.c (read_line, read_line1): Remove check that current
+	input port is open, errors caught by dispatching on closed port.
+
+	* sys.c (init_types): Add a closed port type, so we can avoid I/O
+	to closed FILEs even if we don't explicitly check for a closed SCM
+	port before each operation.
+
+2001-07-21  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c: (char_readyp, lflush, lwrite, display, newline):
+	(write_char, read_char, peek_char, scm_freshline):
+	Don't assume currrent input or output ports are open.
+	Remove checks for EPIPE.
+
+	(lfputc, lfputs, lfwrite): Checks for EPIPE moved here.  Now
+	check errno only if an erring return value is seen.  Signals error
+	for non-EPIPE errors.
+
+	(def_err_response): Exit quietly (without core dump) if default
+	error port has been closed.
+
+	* ioext.c (read_line, read_line1):
+	No longer assume current input port is open.
+
+	* unif.c: (uve_write): Use lfwrite instead of fwrite,
+	(checks for EPIPE).
+
+	* sys.c (safewrite): Fix return value.
+
+2001-07-19  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* sys.c (port_closedp): Added.
+
+2001-07-13  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Link.scm (link:link): Runs 'init_<file>' for all linked
+	object-files with inits.
+
+2001-07-13  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (def_err_response): Deal with closed error-port.
+
+2001-07-12  Steve VanDevender  <stevev@hexadecimal.uoregon.edu>
+
+	* unexalpha.c (TEXT_START): Fixed for Digital UNIX 4.0d and 4.0g.
+
+2001-07-12  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* (scm_port_entry): Fixed for 64-bit machines.
+	(SCM_PORTNUM_MAX): Replaces PORT_TABLE_MAXLEN, fixed for 64-bit
+	machines. Thanks for bug report from Steve VanDevender
+	<stevev@hexadecimal.uoregon.edu>
+
+	(sysintern): Make sure we have a non-garbage-collectable symbol
+	whether it existed previously interned or not.  This can be an
+	issue with dynamically loaded code, since sysintern can be called
+	at any time.
+
+2001-07-02  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (force): Now works for zero or multiple values.
+
+2001-06-27  Steve VanDevender  <stevev@hexadecimal.uoregon.edu>
+
+	* gmalloc.c (check_block, check_frag_blocks): Conditioned on
+	#ifdef DEBUG_GMALLOC.
+
+2001-06-27  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* sys.c (prinport): Print filename or pipe command, if available.
+
+2001-06-23  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* r4rstest.scm (test-numeric-predicates): Added tests for bignum
+	to flonum comparisons.
+
+	* scl.c (lessp, eqp, lmin, lmax): Make bignum to float
+	comparisons transitive as required by R5RS.
+	(scm_twos_power, scm_bigdblcomp): Support functions added.
+
+	* eval.c (m_letstar1): Introduced to allow more sensible error
+	messages for LET, LETREC.
+
+2001-06-17  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* posix.c (scm_getlogin): Added -- doesn't work on RH6.2.
+
+	* Init5d4.scm (getlogin, login->home-directory): Added.
+	(home-vicinity): Defined in terms of getlogin, etc.
+
+2001-06-14  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* subr.c (scm_bitfield): Made more efficient.
+
+2001-06-10  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* scl.c (integer-expt): For negative exponents, raise to a
+	positive power first, then reciprocate.  This should almost always
+	reduce roundoff error..  For INUMs, convert to floats before
+	raising to the positive power, to avoid allocating bignums.
+
+	(next-double-float): Takes two flonums, returns the next flonum
+	from the first in the direction of the second.  Not sure whether
+	this should stay.
+
+2001-05-28  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* r4rstest.scm (test-inexact): Added (test (atan 1) atan 1 1).
+
+2001-05-23  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (ceval_1, ceval_1): Optimize LAMBDA expressions without
+	rest arguments in function call position to LETs.  Introduce
+	IM_FUNCALL spcsym for other non-variable reference expressions in
+	function call position so they are not repeatedly expanded.
+
+2001-05-16  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (pdf): Added targets.
+
+2001-05-15  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* Macro.scm: (macro:compile-syntax-rules): Generalized ellipsis
+	quote from (... ...) to (... <pattern-or-template>).
+
+	* sys.c: (free_storage): Zero loc_gc_hook since it will be freed,
+	otherwise restart may fail.
+
+2001-05-14  Steve VanDevender  <stevev@hexadecimal.uoregon.edu>
+
+	* eval.c (scm_arity_check): Lacked explicit return value in the
+	tcs_closures case.
+
+2001-05-05  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Macro.scm (@pprint): Added.
+
+2001-04-17  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (scm_eval_values): Now applies eval, so that
+	values-context errors are caught for expressions entered in the
+	repl.  Example bug: > (cons (values) '()) => (#<undefined>)
+
+	(ceval_1): Primitive @EVAL does not copytree its argument.
+
+	* Init5d4.scm (eval): Now defined in terms of @eval.
+
+2001-04-16  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (all): make x.so after other components.
+	(myscm): Removed target; use 'make all' instead.
+
+2001-04-16  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* scl.c (previous_dfloat, next_dfloat, dfloat_parts): Fixed
+	for gradual underflow, as long as DBL_MIN_EXP is #defined.
+
+	* repl.c scm.h Init5d4.scm
+	* eval.c (ceval_1, apply, cvapply): Moved most of the work of
+	applying a closure into ceval_1, by providing a syntax token
+	IM_EVAL_FOR_APPLY.  CALL-WITH-VALUES is now a specfun, no special
+	form or closure needed.
+
+2001-04-13  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* scl.c (dfloat_parts, make_dfloat, next_dfloat):
+	(previous_dfloat): Implement DOUBLE-FLOAT-PARTS,
+	MAKE-DOUBLE-FLOAT, NEXT-DOUBLE-FLOAT, PREVIOUS-DOUBLE-FLOAT.  Low
+	level floating point functions.
+
+2001-04-10  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* subr.c (scm_copybit): No longer makes so many bignums.
+	(scm_2scomp1): Static auxiliary function.
+	(scm_big_ash): Uses scm_2scomp1.
+
+2001-04-09  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* subr.c (scm_big_ash, scm_ash): Faster bignum ash,
+	allocates only one bignum per call.
+	(scm_copy_big_2scomp): Static support routine.
+
+2001-04-07  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (scm_stack_trace): Reworked with general stack-inspection
+	function estk_frame.
+	(def_err_response): Use null s_subr argument to indicate that an
+	entire expression is being printed.
+
+	* eval.c (macroexp1): Check early for unbound variable references
+	in a form, so nicer error messages can be produced.
+
+2001-04-06  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* subr.c (scm_big_and): Fixed bug in LOGAND for one negative and
+	one positive argument.
+	Bug example: (logand #x-10000 #x3ffffffff) => #x3ffffffff
+
+2001-04-04  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* Macro.scm (macro:compile-syntax-rules): Better error messages,
+	renamed some internal functions for clarity.  Fix checking of
+	pattern variable rank in templates.  Some legal syntax-rules
+	templates were being rejected, eg
+	(syntax-rules () ((_ (?x ...) (?y ...))
+	                  (let ((?x (list ?y ...)) ...)
+	                    (list ?x ...)))))
+
+2001-03-30  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (scm_values): Exported, since it can reasonably be called
+	from subrs.
+
+	* record.c (recprin1): Call default printer if the custom printer
+	returns #F.  Print object-hash value of the rtd after type name,
+	so all distinct record types can be distinguished by eye.
+
+	(rec_rtdprin1): Custom printer for record type descriptors,
+	includes rtd object-hash value.
+
+2001-03-29  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* repl.c (everr): Pass a `writing' value of 2, rather than
+	1, during printing of error messages, so writing procedures
+	may take special action.
+
+	* record.c (recprin1, rec_prinset): record-printer now takes
+	three arguments instead of two, the third being a boolean
+	WRITING?.
+	Supress calling the record-printer during error reports,
+	avoiding the possibility of a recursive error.
+
+	* eval.c (m_letrec1): Fix error report in case macro keyword
+	is a synthetic identifier.
+	(m_letstar): Preserve distinction between LET* and LET in the
+	printed representation of evaluated code, for easier debugging of
+	backtraces.
+
+2001-03-24  Dai Inukai  <GAF05426@nifty.ne.jp>
+
+	* scmmain.c (main): Since release 2.0.5, FreeBSD's double
+	precision arithmetic defaults to 53 bits instead of 64 bits.  Set
+	precision to 64 bits for all arithmetics and run the risk of
+	overflow, though I have not seen any in 6 months of use.
+
+2001-03-27  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* Macexp.scm (macro:expand):
+	* eval.c (scm_macroexpand1): Now expand identifier macros.
+
+2001-03-26  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* Macro.scm (syntax-rules): Only use procedure->identifier-macro
+	if needed, so macros print something without an error message.
+
+	* eval.c (scm_macroexpand1): Expand forms with identifier macros
+	in keyword position (needed for macro:expand).  Should also expand
+	single identifiers ...
+
+2001-03-23  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	*sys.c (scm_gc_hook, scm_run_finalizers, mark_finalizers):
+	Added hook to be run like an interrupt shortly after gc.  Added
+	finalizer facility to gc.
+	(scm_add_finalizer): Implements Scheme-level interface to
+	finalizer facility, ADD-FINALIZER.
+
+	*scm.c (process_signals): run scm_gc_hook.
+	(setitimer): beautified somewhat.
+
+	*repl.c (scm_top_level): Modified for gc hook.
+
+2001-03-20  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (ceval_1): modified
+	(values, m_call_wv, scm_eval_values): Added.
+	Implement CALL-WITH-VALUES and VALUES by returning extra values in
+	scm_env_tmp.
+	(scm_arity_check): Raise an error for unknown tc7_specfuns.
+
+	* repl.c (repl): Expects and prints multiple values.
+
+	* Init5d4.scm (call-with-values): Implemented by wrapping
+	undocumented special form @CALL-WITH-VALUES.  CALL-WITH-VALUES
+	is hard to implement using the C level apply function, because
+	that function is not tail-recursive.
+
+2001-03-18  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* build.scm (build): Removed unused parameter scm-srcdir.
+
+	* scm.spec (%post): 'ln -s %{prefix}/lib/scm /usr/local/lib/scm'
+	fixes vicinity problem caused by linking /usr/local/bin/scm.
+
+Thu Mar 15 21:33:30 EST 2001  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+
+	* patchlvl.h (SCMVERSION): Bumped from 5d3 to 5d4.
+
+2001-03-15  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* x.c (init_x): Don't scm_ldprog("xatoms.scm") because it
+	redefines STRING.
+
+2001-03-15  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* scm.spec: Added spec file to generate a .rpm file.
+
+2001-03-13  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* Macro.scm (macro:compile-syntax-rules): Support for identifier
+	macros.
+
+	* repl.c (iprin1): Print inlined procedure calls without infinite
+	recursion.
+
+	* scm.h: subtypes of tcs_cons_imcar are broken out for use in repl.c.
+
+	* eval.c (makidmacro): Implement PROCEDURE->IDENTIFIER-MACRO.
+	(macroexp1, lookupcar, prinmacro): Clean up macro type codes,
+	support identifier macros.
+
+	(m_inline_lambda, env_depth, env_tail, ceval_1): Support inline
+	procedures.  Commented out for now, since the macro expander is not
+	yet smart enough to figure out which lambda expressions can be
+	inlined.
+
+2001-03-04  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* unif.c (init_unif): Removed scm_ldstr() call -- was failing to
+	define string-case functions when compiled on files.posmikk.
+
+	* Init5d3.scm (string-case): provided if string-upcase! defined.
+	(display-file): Take optional port argument.
+
+2001-02-25  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* build.scm (build:serve): Improved error reporting.
+
+2001-02-22  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* record.c (rec_constr): Fixed error checking of fields argument.
+
+2001-02-12  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Init5d3.scm (pprint): Added (returns last argument).
+
+2001-02-07  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* unif.c (init_unif): Moved string-*case definitions from
+	Init5d3.scm.  Added string-append.
+
+2001-01-30  Marc Espie  <espie@lusheeta.liafa.jussieu.fr>
+
+	* build.scm, *.c: Ported to OpenBSD.
+
+2001-01-21  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* x.c (x_event_keysym): Added.  Translates XKeyEvent to KeySym.
+	(x_window_geometry_set): Added interface to XConfigureWindow.
+
+	* Makefile (keysymdef.scm): Added target.
+
+	* inc2scm (scm<-includes): #ifdef each prospective #define.
+
+2001-01-18  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* ramap.c (ramap_cxr): Fix bug in dynamic allocation of
+	workspace for large number of arguments (>= 5 in argument list).
+
+2001-12-18  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* Makefile (xafiles): Generated xlib-scheme files weren't being
+	installed.
+
+2001-01-18  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* x.c (scm2display_screen): Fixed off-by-one problem.
+
+2000-12-06  Aubrey Jaffer  <agj@alum.mit.edu>
+
+	* r4rstest.scm (Section 5 2 1): added (begin)s.
+
+2000-12-04  Radey Shouman  <Shouman@ne.mediaone.net>
+
+	* eval.c (m_begin): now accepts (BEGIN) which evaluates to
+	#<unspecified>.
+	(m_expand_body): checks for memoized (BEGIN) so that empty BEGINs
+	do not interrupt a sequence of internal definitions.  Properly
+	rewrites internal definitions in several BEGINs as one LETREC,
+	rather than several.
+
+2000-11-13  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* x.c (x_default_ccc, x:default-ccc): Added.
+	(x_list_properties, x:list-properties): Added.
+	(x_window_ref, x:window-ref): Added.
+	(tc16_xccc): Added.
+	(CCC2SCM_P, CCC2SCM, xtc_ccc): Added backlinks from CCCs.
+	(print_xccc): Print out device-dependent ColorSpace names.
+
+2000-11-07  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* x.c (x_list_properties): Added.
+	(x_propdata2scm): Fixed.
+
+2000-11-06  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+
+	* xatoms.scm (X:CIEXYZ): Added Xcms formats from Xcms.h.
+
+	* xgen.scm (xatoms): Also grab Xcms formats from Xcms.h.
+
+	* x.c (x_visual_class, x_visual_geometry): Added.
+	(free_visual): Fixed vinfo_mask argument to XGetVisualInfo.
+
+2000-10-30  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* x.c (tc16_xvisual): Now holds XVisualInfo.
+	(x:default-visual): Removed.
+
+	* xtest.scm: Removed use of x:default-visual.
+
+	* xgen.scm (xatoms): Added.
+
+	* xatoms.scm: Translation of Xatom.h added.
+
+2000-10-14  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Init5d3.scm (call-with-open-ports): Added.
+	(call-with-input-file):
+	(call-with-output-file): Use call-with-open-ports.
+
+2000-10-07  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Init5d3.scm (call-with-outputs): Added.
+
+2000-09-24  Jacob Strauss  <jastr@mit.edu>
+
+	* scm.texi (waitpid): Fixed return value paragraph.
+
+2000-09-23  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+
+	* build.scm (build:serve): Added.
+
+2000-09-09  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* r4rstest.scm (display): Test only on chars and strings.
+
+2000-08-05  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* rautil.scm (subarray): Added.
+
+2000-06-11  Ben Goetter <goetter@mazama.net>
+
+	* build.scm (Microsoft-C-nt): Set options correctly for
+	feature 'stack-limit.
+
+	* scmfig.h (MSDOS): NT lacks sbrk().
+
+Sat Jun 3 22:12:39 EDT 2000  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* patchlvl.h (SCMVERSION): Bumped from 5d2 to 5d3.
+
+2000-06-01  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* scm.texi (Making SCM): Updated.
+
+2000-05-02  C Nick Beaudrot <cbeaudro@cs.brown.edu>
+
+	* scmfig.h: __SVR4 is the official Sun flag.
+
+2000-04-18  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* r4rstest.scm (modulo): Added test cases.
+
+2000-04-18  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* subr.c (modulo): Fixed sign handling bug for INUM0, following
+	Dirk Herrmann's <D.Herrmann@tu-bs.de> fix for Guile.
+
+2000-03-31  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* ioext.c (file_set_position): Do not disable port tracking for
+	zero pos.
+
+2000-03-30  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* ioext.c (file_set_position): For tracked ports (line & column
+	number), issue warning and turn off tracking.
+
+	* repl.c (scm_port_col): column numbers made consistently 1-based.
+	Fixed handling of ungetted chars.
+
+2000-03-28  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Makefile (Xlibscm_toc.html): fixed.
+
+	* Transcen.scm (pi, pi*, pi/): Added.
+
+2000-02-24  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Init5d2.scm (warn, error): Don't use PROVIDED?, it can cause
+	error loops.
+	(library-vicinity): Give a meaningful error message if we can't load
+	require.scm.
+
+2000-02-16  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Macexp.scm (macro:expand): Fixed for keywords that would be
+	lexically shadowed except for hygiene.
+
+2000-02-15  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* eval.c (ceval_1): Check for immediate procedure argument to
+	APPLY.
+
+2000-02-14  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Init5d2.scm (read:sharp): Accept #! syntax without checking
+	line-number, so source files may be READ.  Made more robust.
+
+	* Macexp.scm (macro:expand-syntax): Fixed handling of BEGIN with
+	only one subform.
+
+2000-02-11  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* eval.c (env2tree): Rewritten to make it easier to change
+	behavior based on bound values.
+
+2000-02-07  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Macro.scm (define-syntax, let-syntax, letrec-syntax): Made
+	Primitive syntax.
+
+	* eval.c (makro): Abstracts process of making syntax.
+	(makacro, makmacro, makmmacro): Now call makro.
+	(makpmacro, @procedure->primitive-syntax): Scheme level way of
+	defining primitive syntax, meaning syntax that @macroexpand and
+	hence macro:expand will not expand.
+
+	* scm.h (IM_DEFINE): now an ISYM but not SPCSYM, since IM_DEFINE
+	no longer occurs in executable Scheme code there is no reason
+	dispatching on it need be fast.  There is now one spare SPCSYM.
+
+2000-02-06  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Macexp.scm (macro:expand): Fixed handling of CASE.
+
+	* eval.c (m_letstar): Transforms (LET* () ...) into either a
+	BEGIN, a single body form, or, if at top level, a LAMBDA
+	expression.  Wrapping macro arguments in (LET () ... ) to allow
+	internal DEFINE becomes free.
+
+	(ceval_1): Code to deal with zero binding LET* commented out.
+
+	(nullenv_p): Added, since we test for null environments in both
+	m_define and m_letstar.
+
+	(scm_extended_env, env2tree): #define constant
+	ENV_TREED for the car bit that identifies environments that have
+	been migrated out of ecache.
+
+	(wrapenv): Return '() if at top level, instead of
+	allocating a cell for an environment object.
+
+	(topdenote_eq): Added to reduce code size.
+
+	(m_begin): if only one form, just returns it.
+	(scm_macroexpand1): Fixed to work with macro:expand.
+
+2000-02-06  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Macexp.scm: Added, rewritten replacement for Macroexpand.scm.
+	Implements MACRO:EXPAND including LET-SYNTAX and LETREC-SYNTAX.
+	Rewrites synthetic identifiers to symbols for pretty display.
+
+2000-02-04  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* build.scm (C-libraries): __FreeBSD__ uses libncurses.
+
+	* crs.c: __FreeBSD__ includes ncurses.h
+
+2000-02-02  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* scm.texi: Updated documentation for DEFMACRO and SYNTAX-RULES.
+
+	* ramap.c (array_map, array_for_each, array_imap): No longer
+	need to call procedurep, scm_arity_check is sufficient.
+
+	* eval.c (scm_arity_check): Was not doing the right thing if
+	passed an immediate as a procedure.
+
+	(ceval_1): Added ALLOW_INTS_EGC to ensure that a tight
+	loop applying a closure of >3 arguments will handle signals.  Bug
+	report thanks to Tomas Lozano-Perez <tlp@mit.edu>.
+
+2000-02-01  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Xlibscm.texi: TeX doesn't like @itemx in @tables.
+
+2000-02-01  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Macro.scm (compile-pattern): Allow (... ...) escapes to be
+	matched in patterns as a literal ... ellipsis, allowing use of
+	ellipses as syntax in user macros.
+
+	* sys.c (scm_env_cons3): Added.
+	* eval.c (scm_env_cons_tmp): Removed, replaced in one remaining
+	use by scm_env_cons3.
+
+2000-01-28  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Init5d2.scm (file-exists?, file-readable?): Zero errno to
+	prevent spurious error messages.
+
+	* Macro.scm (@print): Moved from Init*.scm, where it did no good
+	since 'macro was never provided at that stage.
+
+	(destructuring-bind): SYNTAX-RULES version, gives better error
+	reporting.
+
+2000-01-28  Dorai Sitaram <dorai@owlnet.rice.edu>
+	(actually contributed March 1993)
+
+	* Init5d2.scm (destructuring-bind):
+	(defmacro:get-destructuring-bind-pairs): Added for destructuring
+	DEFMACRO.
+
+2000-01-28  Radey Shouman  <Radey_Shouman@splashtech.com>
+	* Init5d2.scm (defmacro:simple-defmacro): Added, does what
+	DEFMACRO used to do.
+	(defmacro): Now does CL style destructuring.
+
+2000-01-27  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Init5d2.scm (defmacro): Now accepts
+	(DEFMACRO (<name> . <args>) ...) as equivalent to
+	(DEFMACRO <name> (<args>) ...)
+
+2000-01-24  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* eval.c (map, for_each): Check that the cdr of each list
+	argument is in fact a pair -- averting possible segfault.
+
+2000-01-11  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Makefile (SCMLIT, SCMEXE): local executables for build, bench, ...
+
+2000-01-09  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Init5d2.scm (track-all, stack-all, break-all): Added autoloads.
+	(trace, break): Improved Macro Autoloads.
+
+2000-01-04  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Init5d2.scm (boot-tail): Added -h(ave) feature option.
+
+2000-01-03  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* Init5d2.scm (error, warn): print-call-stack.
+
+1999-12-23  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* repl.c (scm_top_level): Moved dowinds() call later in the error
+	recovery sequence so that the errjmp_recursive flag is cleared
+	before calling DYNAMIC-WIND exit thunks.  This move prevents
+	spurious "recursive error" exits.
+	Bug report by Tomas Lozano-Perez <tlp@ai.mit.edu>.
+
+1999-12-17  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* scm.texi (Bibliography): Added (Japanese) SchemePrimer.
+
+1999-12-17  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* Init5d2.scm (@print): Added.
+
+1999-12-10  Aubrey Jaffer  <jaffer@ai.mit.edu>
+
+	* r4rstest.scm (SECTION 6 9): Added tests for map of single
+	argument +, -, and *.
+
+1999-12-10  Radey Shouman  <Radey_Shouman@splashtech.com>
+
+	* eval.c (scm_cvapply): Fixed bug in handling of asubrs.
+
+Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5d1 to 5d2.
 
-1999-12-02  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-12-02  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile (install): Make sure $(libscmdir)require.scm exists.
 	(libscmdir): Use instead of IMPLPATH.
@@ -16,11 +1366,11 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* repl.c (scm_top_level): Corrected error test on exit in case 0
 	is not success.
-	
+
 	(repl): Return MAKINUM(EXIT_SUCCESS) when exiting an interactive
 	session on EOF, this should not be an error.
 
-1999-11-14  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-11-14  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build.scm (define-compile-commands): Added.
 	(defcommand): Added.
@@ -53,7 +1403,7 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	evaluates a list of expressions and returns a list allocated on
 	the ecache in scm_env_tmp.
 
-	(m_do): (m_letrec1): (ceval_1): LET, LETREC, and DO now call
+	(m_do, m_letrec1, ceval_1): LET, LETREC, and DO now call
 	ecache_evalx instead of using inline loops, this seems to improve
 	speed by 5% - 10% for jacal and for simsynch simulation.  C stack
 	usage will increase somewhat for large env frames.
@@ -69,23 +1419,23 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 1999-11-04 David Yeh <theyeh@uclink.berkeley.edu>
 	* scl.c (makdbl): Mods to compile using MSVC
 
-1999-11-01  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-11-01  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* gmalloc.c: include "getpagesize.h" conditionalized on __svr4__.
 
-1999-10-31  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-10-31  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build.scm (batch:chop-to-fit-system): Removed.  Use new
 	batch:try-chopped-command instead.
 	(mysql): Added to features.
 	(build:build): Added comments describing stages and errors.
 
-1999-10-17  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-10-17  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile: Added platform.txi dependency where dependent on
 	scm.texi.
 
-1999-10-16  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-10-16  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile (scm.info require.scm): "cp -p" more portable than "cp -a"?
 
@@ -104,7 +1454,7 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	will hold a mode string suitable to pass to fopen(), without any
 	SCM extension characters.
 
-1999-10-13  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-10-13  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* r4rstest.scm (float-print-test): stop after first error.
 
@@ -124,20 +1474,20 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* ramap.c (cind): Now takes C vector of indices, which may be
 	allocated on the C stack, rather than a uve.
 
-	(ramapc): (ramap): (ramap_cxr): (array_imap): (array_for_each): (rafe):
+	(ramapc, ramap, ramap_cxr, array_imap, array_for_each, rafe):
 	Use scm_cvapply instead of apply, allocate index and argument vectors
 	on the C stack for array ranks < 5.
 
-	* record.c (makrectyp): (recprin1): Use scm_cvapply instead of
+	* record.c (makrectyp, recprin1): Use scm_cvapply instead of
 	apply.
 	(rec_prinset): Checks arity of argument procedure.
 
-	* sys.c (sfputc): (sfwrite): (sfgetc): Use scm_cvapply instead of
+	* sys.c (sfputc, sfwrite, sfgetc): Use scm_cvapply instead of
 	apply.
 	(mksfpt): Checks arities of soft port procedures when the port is made.
 
-	* eval.c (scm_cvapply): (scm_arity_check): Exported.
-	(makacro): (makmacro): (makmmacro): Call scm_cvapply rather than
+	* eval.c (scm_cvapply, scm_arity_check): Exported.
+	(makacro, makmacro, makmmacro): Call scm_cvapply rather than
 	consing up argument lists.  Check arity of macro transformers
 	once, when syntax is defined.
 
@@ -159,13 +1509,13 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 1999-10-04  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* eval.c (scm_arity_check): (macroexp1): Argument number checking
+	* eval.c (scm_arity_check, macroexp1): Argument number checking
 	in macroexp1 abstracted as scm_arity_check, for use in map,
 	for-each ...
-	(scm_cvapply):  Apply a function to a C vector of arguments, used by
+	(scm_cvapply): Apply a function to a C vector of arguments, used by
 	map and for-each.
-	(scm_v2lst):  Added for use in scm_cvapply.
-	(map): (for_each): Speed considerably improved: No longer allocate
+	(scm_v2lst): Added for use in scm_cvapply.
+	(map, for_each): Speed considerably improved: No longer allocate
 	Scheme vector temporaries for up to 5 list arguments.  No longer
 	allocate unnecessary argument lists, allocate on ecache if
 	possible.
@@ -175,7 +1525,7 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* sys.c (scm_env_v2lst): Now takes last cdr of list as argument.
 
-1999-09-21  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-09-21  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* sys.c (scm_port_entry): Make 16-bit safe.
 
@@ -184,21 +1534,21 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* Tscript.scm: File added to implement transcript-on,
 	transcript-off without burdening normal i/o.
 
-	* Init5d1.scm (transcript-on): (transcript-off): Now autoloads
+	* Init5d1.scm (transcript-on, transcript-off): Now autoloads
 	from SCM/Tscript.scm
 
 	(_TRACKED): Added.
 
-	* socket.c (l_socket): (l_connect): (l_listen): Modified to use
+	* socket.c (l_socket, l_connect, l_listen): Modified to use
 	port table.
 
-	(l_shutdown): (l_getpeername): (l_getsockname): Test for OPFPORTP, not
+	(l_shutdown, l_getpeername, l_getsockname): Test for OPFPORTP, not
 	just OPPORTP.
 
 	* posix.c (l_pipe): Modified to use port table.
 	(prinpipe): Removed.
 
-	* ioext.c (reopen_file): (l_dup): (l_dup2): Modified to use port
+	* ioext.c (reopen_file, l_dup, l_dup2): Modified to use port
 	table.
 
 	* crs.c (prinwindow): Removed.
@@ -206,19 +1556,17 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	(mkwindow): Uses scm_port_entry.
 
 	* repl.c (iprin1): Uses "name" field for printing ports.
+	(input_waiting, wait_for_input, trans_on, trans_off): Removed in
+	favor of soft-port implementation.
 
-	(input_waiting):  (wait_for_input):
-
-	(trans_on): (trans_off): Removed in favor of soft-port implementation.
-
-	(lputc): (lgetc): (lputs): (lfwrite): (lungetc): Removed check for
+	(lputc, lgetc, lputs, lfwrite, lungetc): Removed check for
 	transcript, added line and column number support.  Unread char now
 	kept in port table rather than CAR.
 
-	(lreadpr): (line_num): Removed line counting for load port, now done
+	(lreadpr, line_num): Removed line counting for load port, now done
 	using general line and column counting.
 
-	(scm_port_line): (scm_port_column): (scm_port_filename): Added.
+	(scm_port_line, scm_port_column, scm_port_filename): Added.
 
 	(err_head): Now prints out multiple filenames for nested loads.
 	Tries to recover from recursive errors if current-error-port is a
@@ -227,24 +1575,24 @@ Sun Dec 5 22:04:18 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* unif.c (uve_read): Removed ungetc call, if there is an unread
 	character, just call lgetc repeatedly for the first elt.
 
-	* sys.c (must_malloc): (must_realloc): Now check whether the heap
+	* sys.c (must_malloc, must_realloc): Now check whether the heap
 	is initialized or not, so may be called earlier.
 
-	(scm_init_gra): (scm_grow_gra):  Use above feature.
+	(scm_init_gra, scm_grow_gra): Use above feature.
 
-	(scm_port_entry):  Added, allocates entry in a port table used to store
+	(scm_port_entry): Added, allocates entry in a port table used to store
 	unread characters, file names, line & column numbers, &c.
 
-	(mark_port_table): (sweep_port_table): Gc support for port table.
+	(mark_port_table, sweep_port_table): Gc support for port table.
 
 	ptobfuns now has a "name" element, used for printing.
-	(prinfport): (prinstpt): (prinsfpt):  Removed.
+	(prinfport, prinstpt, prinsfpt): Removed.
 
-Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5d0 to 5d1.
 
-1999-09-12  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-09-12  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* x.c (init_x): Load "xevent.scm".
 
@@ -256,7 +1604,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* requires.scm: Sample "require.scm".
 
-1999-09-11  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-09-11  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Xlibscm.texi (Event): Documented x:event-ref.
 
@@ -273,7 +1621,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* repl.c (def_err_response): Now prints "expand-time environment"
 	message only when relevant.
 
-1999-08-21  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-08-21  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* xgen.scm (event-map): Added.
 
@@ -284,11 +1632,11 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* repl.c (def_err_response): Error message for expand-time only
 	environment.
 
-	* eval.c (lookupcar): (id_denote): Now handle environment objects
+	* eval.c (lookupcar, id_denote): Now handle environment objects
 	in scm_env, lookupcar will complain if this happens in a run-time
 	(rather than expand-time) context.
 
-	(eval_syntax):  Added, to be used in Macroexpand.scm for LET-SYNTAX,
+	(eval_syntax): Added, to be used in Macroexpand.scm for LET-SYNTAX,
 	LETREC-SYNTAX.
 
 	(ceval_1): Fixed bug in eval.
@@ -314,7 +1662,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	`scm_trace'.  Nested expressions involving primitives now give
 	more accurate stack traces, without a speed penalty.
 
-	(map): (for_each):  Always push an estk frame for the sake of stack
+	(map, for_each): Always push an estk frame for the sake of stack
 	tracing.
 
 	* repl.c (scm_stack_trace): Now may print out the value of the
@@ -342,7 +1690,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* repl.c (def_err_response): Changed setjump to setjmp when
 	setting up safeport.
 
-1999-07-11  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-07-11  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile (incdir): Added to abstract include directory location.
 
@@ -361,11 +1709,11 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	prototypes if they are small enough to be elements of a uvect,
 	similarly for negative bignums and ivects.
 
-	(make_uve): (arrayp): Now use scm_prot2type.
+	(make_uve, arrayp): Now use scm_prot2type.
 
 	SINGLES no longer need to be #DEFINEd in order to allow fvects.
 
-	* ramap.c:  Modifications for fvects if SINGLES not #DEFINEd.
+	* ramap.c: Modifications for fvects if SINGLES not #DEFINEd.
 
 1999-07-06  Radey Shouman  <Radey_Shouman@splashtech.com>
 
@@ -374,7 +1722,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	conform to R5RS, in response to posting of Allegro Petrofsky
 	<Allegro@Petrofsky.Berkeley.CA.US> to comp.lang.scheme
 
-1999-07-04  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-07-04  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* crs.c (lwinsch): Renamed from lwinsert.  Why were idlok and
 	nodelay commented out?
@@ -448,7 +1796,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	below -MAXEXP, since this such numbers can be represented with
 	gradually underflowing denormals.
 
-1999-04-15  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-04-15  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile (require.scm): Added constructor.
 
@@ -489,7 +1837,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* sys.c (scm_grow_gra): Fixed error in mallocated accounting, made
 	increment grow with allocated size.
 
-1999-03-22  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-03-22  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Init5d0.scm (exec-self): Undo *script* meta-argument processing.
 
@@ -501,7 +1849,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 1999-03-17  Radey Shouman  <Radey_Shouman@splashtech.com>
 
 	* unif.c (raprin1): New write syntax for uniform vectors and arrays.
-	(array2list): (list2ura): Fixed for zero-rank arrays.
+	(array2list, list2ura): Fixed for zero-rank arrays.
 
 	* Init5d0.scm (read:sharp): New read syntax for uniform vectors
 	and arrays.
@@ -542,7 +1890,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* Makefile (mydlls): build edit-line separately to link in
 	libraries correctly.
 
-1999-02-17  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-02-17  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build.scm, mkimpcat.scm, x.c, x.h, x11.scm, xgen.scm, xscm.doc,
 	xtest.scm: Xlib interface from xscm-2.01
@@ -588,7 +1936,7 @@ Sun Sep 12 22:54:58 EDT 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* build.scm (read-version): 5d0 READ as a number; Assemble
 	characters till whitespace.
 
-Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5c4 to 5d0.
 
@@ -605,7 +1953,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* scm.texi (SCM_VERSION): abstracted to version.txi.
 
-1999-01-12  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-01-12  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build (make-readme): moved (require 'posix) here.
 
@@ -615,7 +1963,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* build (make-readme): added.  Makes README from scm5c4.info.
 
-1999-01-11  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-01-11  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Makefile (README): added target.
 
@@ -643,7 +1991,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* ioext.c (director-for-each): fail gracefully if can't open
 	directory.
 
-1999-01-08  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-01-08  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* scm.texi (Smob Cells): Explained NUMDIGS_MAX limit.
 
@@ -663,7 +2011,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* repl.c (heap_report): Only call scm_brk_report() if scm_init_brk
 	has been set.
 
-1999-01-04  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1999-01-04  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* scm.texi (Unix Shell Scripts): merged in "SCSH scripts".
 	Removed description of single non-\ argument on first script line.
@@ -725,14 +2073,14 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 1998-12-14  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* eval.c (m_lambda): (closure): Now checks that argc <= 3 during
+	* eval.c (m_lambda, closure): Now checks that argc <= 3 during
 	memoization instead of each time a closure is made.
 	(macroexp1): Gives more sensible error messages when a
 	non-identifier non-list is in the function position.
 
 1998-12-10  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* (scm_top_level): (repl): Made repl an acceptable second argument to
+	* (scm_top_level, repl): Made repl an acceptable second argument to
 	scm_top_level.
 
 1998-12-09  Aubrey Jaffer  <jaffer@ai.mit.edu>
@@ -796,7 +2144,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	done with native C types.  Moved from subr.c to scl.c because of
 	FLOAT dependencies.
 
-	* eval.c (lookupcar): (ceval_1): Added MEMOIZE_LOCALS cpp macro to
+	* eval.c (lookupcar, ceval_1): Added MEMOIZE_LOCALS cpp macro to
 	control memoization of local variables to ilocs.
 
 1998-12-05  Aubrey Jaffer  <jaffer@ai.mit.edu>
@@ -831,9 +2179,9 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 	* scl.c (makdbl): Combined some DEFER_INTS and ALLOW_INTS,
 	possible because NEWCELL is now callable with ints deferred.
-	(product): (divide): Now scale bignums if necessary before
+	(product, divide): Now scale bignums if necessary before
 	converting them to doubles for calculating inexact results.
-	(big2scaldbl): (bigdblop): (inex_divbigbig): Auxiliary functions
+	(big2scaldbl, bigdblop, inex_divbigbig): Auxiliary functions
 	added.
 	(idbl2str): Decrease minimum exponent to allow printing of
 	gradually underflowing IEEE doubles.
@@ -849,7 +2197,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* scm.h (NUMDIGS): Added cast so that NALLOC error reports would
 	print correctly.
 
-1998-12-02  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-12-02  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* setjump.h: windframe removed -- dowinds could only be processed
 	while (possibly oversize) stack was intact.
@@ -901,7 +2249,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	setjump *must* be called with this argument before using a
 	safeport.
 
-	* repl.c (scm_stack_trace): (def_err_response): Use new
+	* repl.c (scm_stack_trace, def_err_response): Use new
 	safeport features.
 
 	* Macro.scm (substitute-in-template): Added check that all pattern
@@ -936,13 +2284,13 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 1998-11-26  Radey Shouman  <rshouman@metro2000.com>
 
-	* eval.c (ceval): (env2tree): (ident_eqp): Removed redundant
+	* eval.c (ceval, env2tree, ident_eqp): Removed redundant
 	DEFER_INTS_EGC before ENV_PUSH.
 	(ceval_1): Removed label retunspec, replaced by jumps to
 	retx.  Seems to run a tad faster, be a little easier to look at.
 	(copy_list): Now takes second argument giving minimum length of
 	list, allowing the removal of several calls to ilength.
-	(m_case): (m_cond): (ceval_1): ilength checks replaced.
+	(m_case, m_cond, ceval_1): ilength checks replaced.
 
 1998-11-25  Radey Shouman  <Radey_Shouman@splashtech.com>
 
@@ -959,7 +2307,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* sys.c (init_types): Initialize sys_safep to tmp_errp.
 	(reset_safeport): Now does exactly nothing if handed a
 	non-safe-port.
-	(init_types): (init_storage): Moved initialization of tmp_errp and
+	(init_types, init_storage): Moved initialization of tmp_errp and
 	sys_protects earlier, in case allocating ptobs or smobs causes
 	errors to be thrown.
 
@@ -974,7 +2322,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	allocate pairs for a safe-port.
 
 	* repl.c (scm_stack_trace): Now uses sys_safep and reset_safeport.
-	(def_err_response): (handle_it): (repl_driver): (everr):
+	(def_err_response, handle_it, repl_driver, everr):
 	Now checks and dies horribly but predictably if def_err_response
 	is recursively entered.
 
@@ -986,14 +2334,14 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	message (I don't remember when that disappeared) and prints at
 	most 12 traced frames.
 
-	* sys.c (makesafeport): (safewrite): (safeputs): (safeputc):
+	* sys.c (makesafeport, safewrite, safeputs, safeputc):
 	(safeflush): Added support for `safe' ports for error messages,
 	which will accept and re-output only a fixed number of
 	characters. Subsequent characters are simply discarded.
 
 1998-11-19  Radey Shouman  <rshouman@metro2000.com>
 
-	* record.c (rec_error): (rec_accessor1): (rec_modifier1):
+	* record.c (rec_error, rec_accessor1, rec_modifier1):
 	(rec_constr1): Better error reporting, including the name of the
 	expected record type and the relevant field.
 
@@ -1012,7 +2360,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	(renaming-transformer): Added to support `explicit
 	renaming' low-level macros.
 
-	* eval.c (varcheck): (m_lambda): Some checks moved from m_lambda
+	* eval.c (varcheck, m_lambda): Some checks moved from m_lambda
 	to varcheck, argument added to varcheck to give different message
 	(about "formals") in case of lambda.
 	(ENVP): Added predicate macro local to eval.c.
@@ -1022,8 +2370,8 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	* eval.c (varcheck): Renamed from uniqcheck, now checks that
 	elements are identifiers so m_do, m_lambda, m_letrec1 don't have to.
 
-	* Init5c4.scm (alarm-interrupt) (profile-alarm-interrupt)
-	(virtual-alarm-interrupt) Now initially defined to turn off their
+	* Init5c4.scm (alarm-interrupt, profile-alarm-interrupt):
+	(virtual-alarm-interrupt): Now initially defined to turn off their
 	respective alarms, so that restarting does not cause an error when
 	an alarm is pending.
 
@@ -1045,14 +2393,14 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	unmemocar.
 	(uniqcheck): Added, checks for non-unique identifiers in a binding
 	list.
-	(m_lambda): (m_letrec1): (m_do): Now check for duplicate bound
+	(m_lambda, m_letrec1, m_do): Now check for duplicate bound
 	names.
 
 1998-11-13  Radey Shouman  <Radey_Shouman@splashtech.com>
 
 	* unif.c (shap2ra): better error checking of dimension specs
 
-1998-11-12  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-11-12  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* scmfig.h (SCM_NEED_FDS SCM_INTERRUPTED): added argument to make
 	clear that this is not a constant.
@@ -1073,7 +2421,7 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 	If an open fails because there are no unused file handles, GC for
 	for file handles.
 
-1998-11-11  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-11-11  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* Init5c4.scm (vicinity:suffix?): Abstracted from
 	pathname->vicinity and "Link.scm".
@@ -1087,13 +2435,13 @@ Sun Jan 17 14:52:11 EST 1999  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 1998-11-05  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
-	* ioext.c (init_ioext): (provide 'directory-for-each) changed to
+	* ioext.c (init_ioext, provide 'directory-for-each) changed to
 	add_feature("directory-for-each"); so ioext.o can be statically
 	linked.
 
 1998-11-04  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* scm.h (ESTK_PARENT): (ESTK_PARENT_WRITABLEP):
+	* scm.h (ESTK_PARENT, ESTK_PARENT_WRITABLEP):
 	(ESTK_PARENT_INDEX): SCM_ prepended, definition moved to scm.h,
 	now used in repl.c.
 
@@ -1111,7 +2459,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5c3 to 5c4.
 
-1998-11-03  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-11-03  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* ioext.c (directory-for-each): Added.
 
@@ -1121,7 +2469,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* sys.c (makcclo): Fixed argument to ASSERT.
 
-1998-11-02  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-11-02  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* record.c rgx.c scm.texi socket.c subr.c sys.c unif.c: Callers to
 	must_malloc and friends now check that length will fit in field.
@@ -1144,18 +2492,18 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-10-29  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* eval.c (m_and): (m_or): Special case for one argument.
+	* eval.c (m_and, m_or): Special case for one argument.
 
 1998-10-28  Radey Shouman  <Radey_Shouman@splashtech.com>
 
 	* setjump.h
-	* sys.c (scm_make_cont): (scm_dynthrow): (egc_copy_roots):
+	* sys.c (scm_make_cont, scm_dynthrow, egc_copy_roots):
 	No longer copy scm_estk if CHEAP_CONTINUATIONS is #defined.
 
 	* eval.c (ceval_1): Fix up environment stack accounting for
 	CHEAP_CONTINUATIONS.
 
-1998-10-27  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-10-27  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* scm.c (scm_init_extensions): Added call to init_user_scm
 	for RTL case.
@@ -1168,13 +2516,13 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* Init5c3.scm (with-XXX-to-port): Oops. fixed earlier change.
 
-1998-10-19  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-10-19  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* scm.texi (Build Options): Build platform table in Makefile and
 	@include.
 
 1998-10-19  Radey Shouman  <Radey_Shouman@splashtech.com>
-	* dynl.c (l_dyn_call): (l_dyn_main_call): Now use new P_SHL macro,
+	* dynl.c (l_dyn_call, l_dyn_main_call): Now use new P_SHL macro,
 	prevents compiler warning under hpux.
 
 	* sys.c (scm_free_gra): Now sets elts pointer to zero.
@@ -1182,7 +2530,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	(egc_sweep): Give dead cells immediate values, prevents obscure
 	gc bug seen in hpux.
 
-	* sys.c (scm_estk_grow): (scm_estk_shrink): Deleted incorrect
+	* sys.c (scm_estk_grow, scm_estk_shrink): Deleted incorrect
 	DEFER/ALLOW_INTS.
 
 	(init_storage): SHORT_INT fixconfig message now suggests changing
@@ -1217,11 +2565,11 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* sys.c (scm_estk_reset): Now takes an argument giving the size of
 	the environment stack to create, 0 gives a default size.
 
-	(scm_estk_grow): (scm_estk_shrink): Rewritten to use segmented
+	(scm_estk_grow, scm_estk_shrink): Rewritten to use segmented
 	stack, so all of the stack need not be copied when the stack grows
 	or when a continuation is captured.
 
-	(scm_env_cons): (scm_env_cons2): (scm_env_cons_tmp):
+	(scm_env_cons, scm_env_cons2, scm_env_cons_tmp):
 	(scm_extend_env): Rewritten using local temporary for indexing
 	into ecache.
 
@@ -1230,7 +2578,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* scm.c: SIGPROF #undefined if LACK_SETITIMER is #defined, needed
 	to build profiling version of SCM.
 
-1998-10-06  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-10-06  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build.scm (read-version): Will use implementation-vicinity if
 	scm-srcdir does not contain "patchlvl.h".
@@ -1239,7 +2587,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* scm.c (run_scm): Fixed finals call loop
 
-1998-10-02  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-10-02  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* unif.c, sys.c, subr.c, socket.c, scm.h, scl.c, rgx.c, posix.c:
 	Fixed argument types in calls to must_malloc_cell().
@@ -1269,9 +2617,9 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* sys.c (must_malloc_cell): Takes an argument specifying the CAR
 	of the cell to be returned.
 
-	* scm.h (MAKE_LENGTH): (MAKE_NUMDIGS): Preprocessor macros added.
+	* scm.h (MAKE_LENGTH, MAKE_NUMDIGS): Preprocessor macros added.
 
-1998-09-29  Aubrey Jaffer  <aubrey_jaffer@splashtech.com>
+1998-09-29  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* build (build-from-argv): slib:warns if not successful.
 	(bi): Exits with error indication when build not successful.
@@ -1282,13 +2630,13 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-09-22  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* sys.c (scm_init_gra): (scm_grow_gra): (scm_free_gra): GRowable
+	* sys.c (scm_init_gra, scm_grow_gra, scm_free_gra): GRowable
 	Array type.
-	(newsmob): (newptob): (add_final): Implemented using scm_gra type.
+	(newsmob, newptob, add_final): Implemented using scm_gra type.
 
 1998-09-18  Radey Shouman  <Radey_Shouman@splashtech.com>
 
-	* Init5c3.scm (profile-timer): (milli-alarm): Defined in terms of
+	* Init5c3.scm (profile-timer, milli-alarm): Defined in terms of
 	SETITIMER.
 
 	* sys.c (sysintern): No longer changes the CDR of an existing
@@ -1305,7 +2653,7 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-09-17  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
-	* Init5c3.scm (with-input-from-port): (with-output-to-port):
+	* Init5c3.scm (with-input-from-port, with-output-to-port):
 	(with-error-to-port): Replicated procedure rather than using
 	SWAPPORTS twice.  This in combo with repl.c change fixes Radey's
 	strange multi-process bug!
@@ -1329,11 +2677,11 @@ Tue Nov 3 17:41:40 EST 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* unif.c (resizuve): Fixed accounting of mallocated storage for
 	strings and bitvectors.
 
-	* sys.c (igc_for_alloc): (must_malloc): (must_realloc):
+	* sys.c (igc_for_alloc, must_malloc, must_realloc):
 	(must_malloc_cell):
 	(must_realloc_cell): Fixed accounting of mallocated storage.
 
-	(igc):  Added malloc consistency check for patched gmalloc, conditional
+	(igc): Added malloc consistency check for patched gmalloc, conditional
 	on #define DEBUG_GMALLOC.
 
 	(gc_sweep): Fixed accounting of bignum storage for DIGSTOOBIG case.
@@ -1352,7 +2700,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* gmalloc.c: Imported gmalloc.c from emacs 20.2.1.
 
-	(check_block): (check_frag_blocks): Debugging functions added.
+	(check_block, check_frag_blocks): Debugging functions added.
 
 	* sys.c (scm_protect_temp): Added, is currently, and probably will
 	remain, a noop to force allocation of a SCM temporary on the
@@ -1360,7 +2708,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* scl.c (big2str): Added call to scm_protect_temp.
 
-	* eval.c (map): (for_each): Added calls to scm_protect_temp.
+	* eval.c (map, for_each): Added calls to scm_protect_temp.
 
 	* rgx.c (lregcomp): Added call to scm_protect_temp.
 
@@ -1388,19 +2736,19 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* scmfig.h (VERIFY_INTS): Added macro to print warnings if
 	interrupts are improperly allowed and CAREFUL_INTS is #defined.
 
-	(VOLATILE):  Expands to `volatile' keyword if __STDC__ is #defined.
+	(VOLATILE): Expands to `volatile' keyword if __STDC__ is #defined.
 
 	* sys.c (sys_errp): Interrupt safe system output port added.
-	(scm_estk_reset): (must_malloc): (must_realloc): (scm_make_cont):
+	(scm_estk_reset, must_malloc, must_realloc, scm_make_cont):
 	Now should be run with ints deferred, no longer ever allow ints.
 	scm-estk_reset builds a new stack if scm_estk is BOOL_F.
 
 	* scm.c (process_signals): Modified to print deferred output to
 	sys_errp.
 
-	* eval.c (SCM_ENV_SAVE): (SCM_ENV_RESTORE): now ENV_SAVE,
+	* eval.c (SCM_ENV_SAVE, SCM_ENV_RESTORE): now ENV_SAVE,
 	ENV_RESTORE, local to eval.c
-	(apply): (ceval_1): Ints deferred before call to scm_make_cont,
+	(apply, ceval_1): Ints deferred before call to scm_make_cont,
 	which no longer allows ints.
 	(closure): Now takes the number of required closure arguments as a
 	second argument.
@@ -1409,7 +2757,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* repl.c (iprlist): Uses GCCDR so that fatal error messages during
 	gc may print better.
 	(handle_it): Call to scm_egc made conditional on NO_ENV_CACHE.
-	(growth_mon): (gc_start): (gc_end): (heap_report): Now use
+	(growth_mon, gc_start, gc_end, heap_report): Now use
 	sys_errp.
 	(ints_warn): Added for interrupt warnings using VERIFY_INTS.
 	(scm_stack_trace): Now completely prints stacks up to 20 deep,
@@ -1440,11 +2788,11 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-08-24  Radey Shouman  <radey@colorage.com>
 
-	* scm.c (scmable_signal): (err_signal): (init_signals):
+	* scm.c (scmable_signal, err_signal, init_signals):
 	(ignore_signals):
-	(unignore_signals): (restore_signals): Abstracted signal handling.
+	(unignore_signals, restore_signals): Abstracted signal handling.
 
-	(fpe_signal): (bus_signal): (segv_signal): (alrm_signal):
+	(fpe_signal, bus_signal, segv_signal, alrm_signal):
 	(prof_signal): Removed.
 
 	* repl.c (process_signals): Moved to scm.c
@@ -1453,7 +2801,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-08-20  Radey Shouman  <radey@colorage.com>
 
-	* scm.c (prof_signal): (scm_proftimer): (ignore_signals):
+	* scm.c (prof_signal, scm_proftimer, ignore_signals):
 	(unignore_signals): Added handler for SIGPROF, raised via call to
 	setitimer (Scheme function PROFILE-TIMER).
 
@@ -1483,7 +2831,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-08-17  Radey Shouman  <radey@colorage.com>
 
-	* sys.c (scm_egc): (scm_egc_copy_roots): Eliminated extra root
+	* sys.c (scm_egc, scm_egc_copy_roots): Eliminated extra root
 	argument, made safe because EGC_ROOT is always called with ints
 	deferred.
 
@@ -1492,15 +2840,15 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	(gc_sweep): Now uses HUGE_LENGTH instead of LENGTH for string
 	termination check.
 
-	(must_malloc_cell): (must_realloc_cell): Added.
+	(must_malloc_cell, must_realloc_cell): Added.
 
-	(gc_for_alloc):  Static function abstracts gc calls for malloc/realloc.
+	(gc_for_alloc): Static function abstracts gc calls for malloc/realloc.
 
 	* unif.c (make_uve): Removed call to makestr in order to support
 	huge strings.
-	(resizuve):  Now uses must_realloc_cell.
+	(resizuve): Now uses must_realloc_cell.
 
-	* subr.c (make_vector): (mkbig): (adjbig): Now use
+	* subr.c (make_vector, mkbig, adjbig): Now use
 	must_malloc_cell, must_realloc_cell.
 
 	* socket.c (maksknm): Now uses must_malloc_cell.
@@ -1514,11 +2862,11 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* repl.c (handle_it): Keep pointers to discarded new cells.
 
-	* record.c (rec_constr1): (init_record): Now use must_malloc_cell.
+	* record.c (rec_constr1, init_record): Now use must_malloc_cell.
 
 	* posix.c (scm_getgroups): Now uses must_malloc_cell.
 
-	* dynl.c (l_dyn_link): (l_dyn_call): Moved NEWCELL out of deferred
+	* dynl.c (l_dyn_link, l_dyn_call): Moved NEWCELL out of deferred
 	ints sections.  For dlopen versions, print more error messages.
 
 1998-08-17  Aubrey Jaffer  <jaffer@colorage.com>
@@ -1548,7 +2896,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* sys.c (scm_estk_grow): Now pushes estk ptr, with ints deferred.
 
-	* eval.c (ENV_PUSH): (ENV_POP): Now done with DEFER_INTS_EGC to
+	* eval.c (ENV_PUSH, ENV_POP): Now done with DEFER_INTS_EGC to
 	prevent problems with interrupt handlers that run Scheme code.
 
 1998-07-27  Radey Shouman  <radey@colorage.com>
@@ -1556,7 +2904,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* sys.c (scm_estk_grow): Protected critical section with
 	DEFER/ALLOW_INTS
 
-	(must_malloc): (must_realloc): Protected igc call with
+	(must_malloc, must_realloc): Protected igc call with
 	DEFER/ALLOW_INTS.
 
 	(scm_egc): Added DEFER/ALLOW_INTS around call to igc -- prevents
@@ -1565,7 +2913,7 @@ Fri Sep 11 17:25:14 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	(igc): Now SCM_ENV_SAVE before any gc marking to fix gc bug
 	tickled by running Scheme code from interrupts.
 
-	(scm_egc): (scm_egc_copy_roots): Now take a single argument, a gc
+	(scm_egc, scm_egc_copy_roots): Now take a single argument, a gc
 	root.  Simplifies handling of the case where scm_egc calls igc,
 	and possibly itself.
 
@@ -1589,10 +2937,10 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	several meaningful values for ints_disabled.
 	(handle_it): More careful about interrupts when saving estk.  *
 
-	*scmfig.h (DEFER_INTS): (ALLOW_INTS): (DEFER_INTS_EGC):
+	*scmfig.h (DEFER_INTS, ALLOW_INTS, DEFER_INTS_EGC):
 	(ALLOW_INTS_EGC): ints_viol calls changed.
 
-	* ramap.c (array_for_each): (array_map): Always act as if CCLO is
+	* ramap.c (array_for_each, array_map): Always act as if CCLO is
 	defined, this does no harm, and allows CCLO optimizations for the
 	dynamicly loaded case.
 
@@ -1602,7 +2950,7 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	IDENTIFIER->SYMBOL.
 	(closure): Removed env argument, now uses scm_env and is more careful
 	about interrupts.
-	(env2tree):  Now uses DEFER_INTS_EGC.
+	(env2tree): Now uses DEFER_INTS_EGC.
 
 1998-07-22  Aubrey Jaffer  <jaffer@colorage.com>
 
@@ -1649,23 +2997,23 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-07-14  Radey Shouman  <radey@colorage.com>
 
-	* eval.c (ENV_PUSH): (ENV_POP): Modified for interrupt safety.
+	* eval.c (ENV_PUSH, ENV_POP): Modified for interrupt safety.
 
-	(ceval_1): (apply): (procedurep): (macroexp1): (make_specfun):
+	(ceval_1, apply, procedurep, macroexp1, make_specfun):
 	cclo is now a subtype of tc7_specfun, which also includes
 	tc16_apply and tc16_call_cc, smobs are now never procedures.
 
 	(apply): Added call/cc support, error checking for subr_2o and
 	subr_3 types.
 
-	* sys.c (gc_mark): (gc_sweep): Modified for new specfun, cclo
+	* sys.c (gc_mark, gc_sweep): Modified for new specfun, cclo
 	representation.
 
 	(gc): Now does ecache gc if given optional argument.
 
 	* repl.c (iprin1): Modified for new specfun, cclo representation.
 
-	(handle_it):  Now saves and restores estk for interrupt safety.
+	(handle_it): Now saves and restores estk for interrupt safety.
 
 	* ramap.c (array_map): Changed for new cclo representation.
 
@@ -1691,10 +3039,10 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	(m_body): Added, error checks bodies and inserts the ISYM tokens.
 
-	(m_lambda): (m_letstar): (m_letrec1): (m_letrec): (m_let): Now
+	(m_lambda, m_letstar, m_letrec1, m_letrec, m_let): Now
 	call m_body.
 
-	(m_cond): (m_case): (m_quote): Modified to avoid destructively changing
+	(m_cond, m_case, m_quote): Modified to avoid destructively changing
 	their argument forms.  Since m_expand_body speculatively macro
 	expands forms the process must be reversible.
 
@@ -1707,7 +3055,7 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 1998-07-07  Radey Shouman  <radey@colorage.com>
 
 	* eval.c (SPECFUN): Removed -- now the only case.
-	(ceval_1): (m_cont): IM_CONT case removed.
+	(ceval_1, m_cont): IM_CONT case removed.
 	(scm_evalatomcar): Added check for tc16_specfun. Made unquoted vector
 	message conditional on RECKLESS.
 
@@ -1725,7 +3073,7 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	* eval.c (ceval_1): Fixed argument number check for closures and
 	made conditional on CAUTIOUS.
 
-	(ceval_1): (evalatomcar): (lookupcar): Moved check for
+	(ceval_1, evalatomcar, lookupcar): Moved check for
 	using macro as variable from ceval_1 and evalatomcar to lookupcar.
 
 1998-07-02  Radey Shouman  <radey@colorage.com>
@@ -1738,7 +3086,7 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	ecache allocated lists now no longer passed to apply of asubrs and
 	rpsubrs -- this is not interrupt safe.
 
-	(macroexp1):  Added argument number checks for subrs, this gives error
+	(macroexp1): Added argument number checks for subrs, this gives error
 	messages with unmemoized code.
 
 	* eval.c (ceval_1): Fixed error reporting -- "wrong number of
@@ -1749,7 +3097,7 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-07-01  Radey Shouman  <radey@colorage.com>
 
-	* eval.c (ceval): (ceval_1): (ilookup): (lookupcar): (farlookup):
+	* eval.c (ceval, ceval_1, ilookup, lookupcar, farlookup):
 	New model of interrupt control for protecting ecache references
 	using DEFER_INTS_EGC, ALLOW_INTS_EGC.  These need not be strictly
 	nested, ints are always allowed by ceval_1 before tail-calling a
@@ -1760,9 +3108,9 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 	(scm_macroexp1): Now checks arity for closures, checking had been
 	broken for non-CAUTIOUS SCM.
 
-	* scmfig.h (DEFER_INTS_EGC): (ALLOW_INTS_EGC): Defined.
+	* scmfig.h (DEFER_INTS_EGC, ALLOW_INTS_EGC): Defined.
 
-	* sys.c (scm_env_cons): (scm_env_cons): (scm_env_cons2):
+	* sys.c (scm_env_cons, scm_env_cons, scm_env_cons2):
 	(scm_extend_env): DEFER_INTS replaced with DEFER_INTS_EGC.
 
 	* repl.c (repl_report): At verbose level 3 now reports number of
@@ -1785,15 +3133,15 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-06-19  Radey Shouman  <radey@colorage.com>
 
-	* eval.c (ilookup): (farlookup): (unmemocar): (ceval_1):
+	* eval.c (ilookup, farlookup, unmemocar, ceval_1):
 	(id_denote): Wrapped all pointer-chasing of possible ecache cells
 	in DEFER/ALLOW_INTS for safety when interrupt handlers may
 	evaluate Scheme code asynchronously.
 
-	(scm_macroexp1): (m_define): (m_atlet_syntax): Environments now
+	(scm_macroexp1, m_define, m_atlet_syntax): Environments now
 	always wrapped when passed to macro expanders.
 
-	(ecache_p): (debug_env_car): (debug_env_cdr): Added for CAREFUL_INTS
+	(ecache_p, debug_env_car, debug_env_cdr): Added for CAREFUL_INTS
 	checking.
 
 	(test_ints): Added when CAREFUL_INTS is defined for checking interrupt
@@ -1803,15 +3151,15 @@ Wed Jul 22 16:36:48 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-06-15  Radey Shouman  <radey@colorage.com>
 
-	* scm.h (SCM_ENV_SAVE): (SCM_ENV_RESTORE): Added, to prevent
+	* scm.h (SCM_ENV_SAVE, SCM_ENV_RESTORE): Added, to prevent
 	oversights in sys.c.
 
-	* sys.c (scm_env_cons): (scm_env_cons2): Made interrupt safe;
+	* sys.c (scm_env_cons, scm_env_cons2): Made interrupt safe;
 	return results in global scm_env_tmp, use DEFER/ALLOW_INTS.
-	(scm_extend_env): (scm_env_cons_tmp): Added.
+	(scm_extend_env, scm_env_cons_tmp): Added.
 	(scm_env_acons): Deleted, superseded by scm_extend_env.
 
-	*eval.c (ceval_1): (apply): Replaced and rewrote scm_env_ routines
+	*eval.c (ceval_1, apply): Replaced and rewrote scm_env_ routines
 	to use new interrupt safe versions.  ENV_TMP replaced by
 	scm_env_tmp, it was hard to remember that ENV_TMP might move.
 	CLEAR_ENV_TMP removed since scm_env_tmp will be overwritten almost
@@ -1959,7 +3307,7 @@ Fri Jun 5 16:01:02 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 	* sys.c: cosmetic changes.
 
-Wed May 20 17:53:52 EDT 1998  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+Wed May 20 17:53:52 EDT 1998  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5b5 to 5c0.
 
@@ -1983,13 +3331,13 @@ Wed May 20 17:53:52 EDT 1998  Aubrey Jaffer  <jaffer@aubrey.jaffer>
 
 1998-05-14  Radey Shouman  <radey@colorage.com>
 
-	* Init.scm (bit-extract): (logical:bit-field):
-	(logical:bitwise-if): (logical:copy-bit):
+	* Init.scm (bit-extract, logical:bit-field):
+	(logical:bitwise-if, logical:copy-bit):
 	(logical:copy-bit-field): definitions added for SLIB compatibility.
 
 	* subr.c (scm_bitfield): renamed BIT-EXTRACT to BIT-FIELD,
 	added range check on END.
-	(scm_bitif): (scm_copybitfield): (scm_copybit): added.
+	(scm_bitif, scm_copybitfield, scm_copybit): added.
 
 1998-05-12  Aubrey Jaffer  <jaffer@colorage.com>
 
@@ -2036,7 +3384,7 @@ Fri May 8 17:40:44 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-04-16    <radey@colorage.com>
 
-	* unif.c (scm_logaref): (scm_logaset): Added.
+	* unif.c (scm_logaref, scm_logaset): Added.
 
 Thu Apr 9 11:31:20 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
@@ -2102,16 +3450,16 @@ Thu Apr 9 11:31:20 EDT 1998  Aubrey Jaffer  <jaffer@scm.colorage.net>
 
 1998-03-26  Radey Shouman  <radey@colorage.com>
 
-	* eval.c (ilookup): (lookupcar): (farlookup): (ceval): (evalatomcar):
-	(ceval_1): (iqq): (wrapenv): Substantial changes to use
+	* eval.c (ilookup, lookupcar, farlookup, ceval, evalatomcar):
+	(ceval_1, iqq, wrapenv): Substantial changes to use
 	copy-collected stack cache intended to reduce time in gc.
 
-	* sys.c (egc_mark): (egc_sweep): (egc_copy): (egc_copy_stack):
-	(egc_copy_roots): (scm_egc): The cache garbage collector.
-	(scm_env_cons): (scm_env_cons2): (scm_env_acons): Functions to
+	* sys.c (egc_mark, egc_sweep, egc_copy, egc_copy_stack):
+	(egc_copy_roots, scm_egc): The cache garbage collector.
+	(scm_env_cons, scm_env_cons2, scm_env_acons): Functions to
 	allocate storage in the environment cache.
 
-	* repl.c (scm_egc_start): (scm_egc_end): (scm_ecache_report):
+	* repl.c (scm_egc_start, scm_egc_end, scm_ecache_report):
 	(scm_stack_trace): Added to support environment cache.
 	stack-trace now does not print all of stacktraces deeper than
 	10 levels.
@@ -2312,7 +3660,7 @@ Sun Sep 28 14:48:10 1997  Radey Shouman  <shouman@zianet.com>
 
 	* ramap.c (array_imap): Fixed for zero-rank arrays arguments.
 
-Fri Sep 19 23:23:46 EDT 1997  Aubrey Jaffer  <jaffer@aubrey.jaffer>
+Fri Sep 19 23:23:46 EDT 1997  Aubrey Jaffer  <jaffer@ai.mit.edu>
 
 	* patchlvl.h (SCMVERSION): Bumped from 5b1 to 5b2.
 
@@ -2550,16 +3898,16 @@ Sat Feb 1 21:41:15 EST 1997  Aubrey Jaffer  <jaffer@scm.bertronics.com>
 
 Sat Jan 25 19:48:19 1997  Radey Shouman  <shouman@zianet.com>
 
-	* scm.h (IM_DELAY) (IM_QUASIQUOTE) (IM_UNQUOTE) (IM_UQ_SPLICING)
-	(IM_ELSE) (IM_ARROW): Added to support hygienic macros.
+	* scm.h (IM_DELAY, IM_QUASIQUOTE, IM_UNQUOTE, IM_UQ_SPLICING):
+	(IM_ELSE, IM_ARROW): Added to support hygienic macros.
 
 	* repl.c: isymnames modified.
 
 	* eval.c (lookupcar): Added support for hygienic macros
-	(evalatomcar):  Added.
-	(ident2sym) (id_denote) (unpaint) (prinid) (ident_eqp)
-	(rename_ident) (syn_quote) (m_atlet_syntax) (m_the_macro): added.
-	(m_quote) (m_cond) (m_case) (m_quasiquote): Modified to be
+	(evalatomcar): Added.
+	(ident2sym, id_denote, unpaint, prinid, ident_eqp)
+	(rename_ident, syn_quote, m_atlet_syntax, m_the_macro): added.
+	(m_quote, m_cond, m_case, m_quasiquote): Modified to be
 	referentially transparent.
 	(m_iqq): added.
 	(m_delay): now memoizes to prevent speed hit from slower lookupcar.
@@ -2592,7 +3940,7 @@ Mon Dec  2 20:40:40 1996  Radey Shouman  <shouman@zianet.com>
 	(ceval): Modified to do the right thing with farlocs.
 
 	* scm.h (MAKILOC): Added, now used in lookupcar.
-	(IM_FARLOC_CDR) (IM_FARLOC_CAR): ISYMS added.
+	(IM_FARLOC_CDR, IM_FARLOC_CAR): ISYMS added.
 
 Sun Dec  1 00:41:07 1996  Aubrey Jaffer  <jaffer@martigny.ai.mit.edu>
 
@@ -2922,9 +4270,9 @@ Sun Mar 24 00:18:10 1996  Aubrey Jaffer  <jaffer@jacal.bertronics>
 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
+	(ramapc): Uses sc2array to convert scalar arguments to arrays
 	        for ARRAY-MAP! &c.
-	(ura_read, ura_write, ura_fill):  Added.
+	(ura_read, ura_write, ura_fill): Added.
 	(array_map): Added check for number of arguments when procedure
 	        arg is a subr.  Added cclo case.
 
@@ -2942,10 +4290,10 @@ Sun Mar 10 17:23:39 1996  Radey Shouman  <shouman@ccwf.cc.utexas.edu>
 	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
+	(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].
+	(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
@@ -3215,7 +4563,7 @@ Sat Mar 25 20:37:48 1995  Aubrey Jaffer  (jaffer@jacal)
 	regex library is conditionalized with _GNU_SOURCE.
 
 	From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
-	* Iedline.scm ((make-edited-line-port)):
+	* Iedline.scm (make-edited-line-port):
 	* edline.c (lreadline): Added Gnu `readline' input editing
 	(get ftp.sys.toronto.edu:/pub/rc/editline.shar).
 
@@ -3307,7 +4655,7 @@ Sat Feb 11 17:30:14 1995  Aubrey Jaffer  (jaffer@jacal)
 	(lexecp i_exec l_putenv): added.
 
 	* posix.c (open_pipe l_open_input_pipe l_open_output_pipe
-	prinpipe):  moved from ioext.c.
+	prinpipe): moved from ioext.c.
 	(l_fork): added.
 
 Fri Feb 10 10:50:03 1995  Aubrey Jaffer  (jaffer@jacal)
@@ -4634,7 +5982,7 @@ Sun Oct  4 01:45:25 1992  Aubrey Jaffer  (jaffer at camelot)
 	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
+	* 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
@@ -4796,7 +6144,7 @@ Wed May 13 14:01:07 1992  Aubrey Jaffer  (jaffer at Ivan)
 
 Tue May 12 15:36:17 1992  Aubrey Jaffer  (jaffer at train)
 
-	* config.h sys.c (alloc_some_heap expmem):  expmem captures
+	* 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.
@@ -5014,7 +6362,7 @@ Mon Feb 10 14:31:24 1992  Aubrey Jaffer  (jaffer at Ivan)
 	* 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
+	* 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
@@ -5035,7 +6383,7 @@ Fri Jan 17 16:36:07 1992  Aubrey Jaffer  (jaffer at Ivan)
 	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
+	* 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)
@@ -5085,7 +6433,7 @@ Thu Dec 19 19:16:50 1991  Aubrey Jaffer  (jaffer at train)
 
 	* makefile.unix (subr.o): explicit compilation line added.
 
-	* scl.c (truncate -> ltrunc):  Name conflict with DJGCC libraries.
+	* scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries.
 
 Sun Dec  8 23:31:04 1991  Aubrey Jaffer  (jaffer at Ivan)
 
diff --git a/Iedline.scm b/Iedline.scm
index 8c076a0..1d49559 100644
--- a/Iedline.scm
+++ b/Iedline.scm
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
diff --git a/Init5d2.scm b/Init5d6.scm
index 946e6d7..a847689 100644
--- a/Init5d2.scm
+++ b/Init5d6.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991-1999 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2002 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
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -42,7 +42,7 @@
 ;;; Author: Aubrey Jaffer.
 
 (define (scheme-implementation-type) 'SCM)
-(define (scheme-implementation-version) "5d2")
+(define (scheme-implementation-version) "5d6")
 (define (scheme-implementation-home-page)
   "http://swissnet.ai.mit.edu/~jaffer/SCM.html")
 
@@ -53,7 +53,7 @@
 	   ((MACOS THINKC)			'(#\:))
 	   ((MS-DOS WINDOWS ATARIST OS/2)	'(#\\ #\/))
 	   ((NOSVE)				'(#\: #\.))
-	   ((UNIX COHERENT)			'(#\/))
+	   ((UNIX COHERENT PLAN9)		'(#\/))
 	   ((VMS)				'(#\: #\])))))
     (lambda (chr) (memv chr suffi))))
 
@@ -76,64 +76,19 @@
 
 (define in-vicinity string-append)
 
-;;; This is the vicinity where this file resides.
-(define implementation-vicinity #f)
-
-;;; (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 #f)
-(define home-vicinity #f)
-(define (set-vicinities! init-file)
-  (set! implementation-vicinity
-	(let ((vic (pathname->vicinity init-file)))
-	  (lambda () vic)))
-  (set! library-vicinity
-	(let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
-	  (if library-path
-	      (lambda () library-path)
-	      (lambda ()
-		(let ((olv library-vicinity)
-		      (oload load))
-		  (dynamic-wind
-		      (lambda () (set! load identity))
-		      (lambda ()
-			(try-load (in-vicinity (implementation-vicinity)
-					       "require.scm")))
-		      (lambda () (set! load oload)))
-		  (if (eq? olv library-vicinity)
-		      (error "Can't find library-vicinity"))
-		  (library-vicinity))))))
-  (set! home-vicinity
-	(let ((home (getenv "HOME")))
-	  (and home
-	       (case (software-type)
-		 ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
-		  (if (not
-		       (char=? #\/
-			       (string-ref home (+ -1 (string-length home)))))
-		      (set! home (string-append home "/"))))))
-	  (lambda () home))))
-(set-vicinities! *load-pathname*)
-
-;;; 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 dynamic-wind fluid-let
-		multiarg-apply multiarg/and- logical defmacro
-		string-port source current-time sharp:semi)
+      (append '(ed getenv tmpnam abort transcript with-file
+		   ieee-p1178 rev4-report rev4-optional-procedures
+		   hash object-hash delay dynamic-wind fluid-let
+		   multiarg-apply multiarg/and- logical defmacro
+		   string-port source current-time sharp:semi)
 	      *features*))
 
+(define eval
+  (let ((@eval @eval)
+	(@copy-tree @copy-tree))
+    (lambda (x) (@eval (@copy-tree x)))))
+
 (define (exec-self)
   (require 'i/o-extensions)
   (execv (execpath) (if *script*
@@ -142,58 +97,76 @@
 				    (member *script* (program-arguments))))
 			(program-arguments))))
 
-(define (display-file file)
+(define (display-file file . port)
   (call-with-input-file file
     (lambda (inport)
       (do ((c (read-char inport) (read-char inport)))
 	  ((eof-object? c))
-	(write-char c)))))
+	(apply write-char c port)))))
 (define (terms)
   (display-file (in-vicinity (implementation-vicinity) "COPYING")))
 
-;; Array syntax:
-;; n is a decimal number, which may be elided for a default value of 1.
-;; #nA\( ... ) character array
-;; #nAt( ... ) boolean array
-;; #nAe[sfdl]( ... ) exact number array
-;; #nAu[sfdl]( ... ) positive exact number array
-;; #nAi[sfdl]( ... ) inexact real number array
-;; #nAic[sfdl]( ... ) inexact complex number array
+(define (read:try-number port . ic)
+  (define chr0 (char->integer #\0))
+  (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0))))
+    (let ((c (peek-char port)))
+      (cond ((eof-object? c) #f)
+	    ((char-numeric? c)
+	     (loop (+ (* 10 (or arg 0))
+		      (- (char->integer (read-char port)) chr0))))
+	    (else arg)))))
 
 (define (read:array rank port)
-  (let ((prot
+  (define (bomb pc wid)
+    (error (string-append "array syntax? #"
+			  (number->string rank)
+			  "A" (string pc)
+			  (if wid (number->string wid) ""))))
+  (list->uniform-array
+   rank
+   (case (char-downcase (peek-char port))
+     ((#\\) (read-char port) #\a)
+     ((#\t) (read-char port) #t)
+     ((#\c #\r)
+      (let* ((pc (read-char port))
+	     (wid (read:try-number port)))
+	(case wid
+	  ((64 32) (case pc
+		     ((#\c) (* +i wid))
+		     (else (exact->inexact wid))))
+	  (else (bomb pc wid)))))
+     ((#\s #\u)
+      (let* ((pc (read-char port))
+	     (wid (read:try-number port)))
+	(case (or wid (peek-char port))
+	  ((32 16 8) (case pc
+		       ((#\s) (- wid))
+		       (else wid)))
+	  ((#\s #\f #\d #\l) (read-char port) 32)
+	  ((#\() 32)			;legacy
+	  (else (bomb pc wid)))))
+     ((#\e)				;legacy
+      (read-char port)
+      (case (char-downcase (peek-char port))
+	((#\s) (read-char port) -16)
+	((#\f #\d #\l) (read-char port) -32)
+	(else -32)))
+     ((#\i)				;legacy
+      (read-char port)
+      (case (char-downcase (peek-char port))
+	((#\c)
+	 (read-char port)
 	 (case (char-downcase (peek-char port))
-	   ((#\\) (read-char port) #\a)
-	   ((#\t) (read-char port) #t)
-	   ((#\e)
-	    (read-char port)
-	    (case (char-downcase (peek-char port))
-	      ((#\s) (read-char port) 'exact-short)
-	      ((#\f #\d #\l) (read-char port) -2)
-	      (else -2)))
-	   ((#\u)
-	    (read-char port)
-	    (case (char-downcase (peek-char port))
-	      ((#\s #\f #\d #\l) (read-char port) 2)
-	      (else 2)))
-	   ((#\i)
-	    (read-char port)
-	    (case (char-downcase (peek-char port))
-	      ((#\c)
-	       (read-char port)
-	       (case (char-downcase (peek-char port))
-		 ((#\s #\f #\d #\l) (read-char port)))
-	       0+1.0i)
-	      ((#\s #\f) (read-char port) 1.0)
-	      ((#\d #\l) (read-char port) 1/3)
-	      (else 1/3)))
-	   (else #f))))
-    (list->uniform-array rank prot (read port))))
+	   ((#\s #\f #\d #\l) (read-char port)))
+	 +64i)
+	((#\s #\f) (read-char port) 32.0)
+	((#\d #\l) (read-char port) 64.0)
+	(else (bomb (read-char port) #f))))
+     (else #f))
+   (read port)))
 
 (define (read:sharp c port)
-  (define (barf c)
-    (error "unknown # object" c))
-  (define chr0 (char->integer #\0))
+  (define (barf c) (error "unknown # object" c))
   (define (feature? exp)
     (cond ((symbol? exp)
 	   (or (memq exp *features*) (eq? exp (software-type))))
@@ -218,60 +191,52 @@
 	       (begin (read port) (if #f #f))))
     ((#\a #\A) (read:array 1 port))
     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-     (let loop ((arg (- (char->integer c) chr0)))
-       (let ((c (peek-char port)))
-	 (cond ((char-numeric? c)
-		(loop (+ (* 10 arg)
-			 (- (char->integer (read-char port)) chr0))))
-	       ((memv c '(#\a #\A))
-		(read-char port)
-		(read:array arg port))
-	       (else
-		(warn "obsolete array read syntax")
-		(read:array arg port))))))
-    ((#\!) (if (= 1 (line-number))
-	       (let skip ((metarg? #f))
-		 (case (read-char port)
-		   ((#\newline) (if metarg? (skip #t)))
-		   ((#\\) (skip #t))
-		   ((#\!) (if (not (and (eqv? #\# (peek-char port))
-					(read-char port)))
-			      (skip metarg?)))
-		   (else (skip metarg?))))
-	       (barf c)))
+     (let* ((num (read:try-number port c))
+	    (c (peek-char port)))
+       (cond ((memv c '(#\a #\A)) (read-char port) (read:array num port))
+	     (else (error "syntax? #" num c)))))
+    ((#\!) (let skip ((metarg? #f))
+	     (let ((c (read-char port)))
+	       (case c
+		 ((#\newline) (if metarg? (skip #t)))
+		 ((#\\) (skip #t))
+		 ((#\!) (cond ((eqv? #\# (peek-char port))
+			       (read-char port)
+			       (if #f #f))
+			      (else (skip metarg?))))
+		 (else (if (char? c) (skip metarg?) c))))))
+    ((#\?) (case (read port)
+	     ((line) (port-line port))
+	     ((column) (port-column port))
+	     ((file) (port-filename port))
+	     (else #f)))
     (else (barf c))))
 
-;; We can assume TOK has at least 2 characters.
+;;; We can assume TOK has at least 2 characters.
 (define read:sharp-char
-  (letrec ((control (lambda (c)
-		      (and (char? c)
-			   (if (eqv? c #\?)
-			       (integer->char 127)
-			       (integer->char
-				(logand 31 (char->integer c)))))))
-	   (meta (lambda (c)
-		   (and (char? c)
-			(integer->char
-			 (logior 128 (char->integer c)))))))
+  (letrec ((process
+	    (lambda (modifier tok)
+	      (and (char=? #\- (string-ref tok 1))
+		   (if (= 3 (string-length tok))
+		       (modifier (string-ref tok 2))
+		       (let ((c (read:sharp-char
+				 (substring tok 2 (string-length tok)))))
+			 (and c (modifier c)))))))
+	   (control
+	    (lambda (c)
+	      (and (char? c)
+		   (if (eqv? c #\?)
+		       (integer->char 127)
+		       (integer->char (logand #o237 (char->integer c)))))))
+	   (meta
+	    (lambda (c)
+	      (and (char? c)
+		   (integer->char (logior 128 (char->integer c)))))))
     (lambda (tok)
       (case (string-ref tok 0)
-	((#\C #\c)
-	 (and (char=? #\- (string-ref tok 1))
-	      (if (= 3 (string-length tok))
-		  (control (string-ref tok 2))
-		  (let ((c (read:sharp-char
-			    (substring tok 2 (string-length tok)))))
-		    (and c (control c))))))
-	((#\^)
-	 (and (= 2 (string-length tok))
-	      (control (string-ref tok 1))))
-	((#\M #\m)
-	 (and (char=? #\- (string-ref tok 1))
-	      (if (= 3 (string-length tok))
-		  (meta (string-ref tok 2))
-		  (let ((c (read:sharp-char
-			    (substring tok 2 (string-length tok)))))
-		    (and c (meta c))))))))))
+	((#\C #\c) (process control tok))
+	((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1))))
+	((#\M #\m) (process meta tok))))))
 
 ;;;; Function used to accumulate comments before a definition.
 (define comment
@@ -290,8 +255,9 @@
 	    (else (set! *accumulated-comments*
 			(append (reverse args) *accumulated-comments*)))))))
 
-;; Make #; convert the rest of the line to a (comment ...) form.
-;; "build.scm" uses this.
+;;; Make #; convert the rest of the line to a (comment ...) form.
+;;; "build.scm" uses this.
+;;; requires line-i/o
 (define read:sharp
   (let ((rdsharp read:sharp))
     (lambda (c port)
@@ -309,12 +275,8 @@
 (define !#(if #f #f))			;for scsh hack.
 
 ;;;; Here are some Revised^2 Scheme functions:
-(define 1+
-  (let ((+ +))
-    (lambda (n) (+ n 1))))
-(define -1+
-  (let ((+ +))
-    (lambda (n) (+ n -1))))
+(define 1+ (let ((+ +)) (lambda (n) (+ n 1))))
+(define -1+ (let ((+ +)) (lambda (n) (+ n -1))))
 (define 1- -1+)
 (define <? <)
 (define <=? <=)
@@ -323,12 +285,14 @@
 (define >=? >=)
 (define t #t)
 (define nil #f)
-(define identity
-  (if (defined? cr) cr (lambda (x) x)))
-
-(if (not (defined? the-macro))
-    (define the-macro identity))
-(define sequence (the-macro begin))
+(define identity cr)
+
+(cond ((defined? defsyntax)
+(defsyntax define-syntax (the-macro defsyntax)))
+      (else
+(define defsyntax define)
+(define the-macro identity)))
+(defsyntax sequence (the-macro begin))
 (define copy-tree @copy-tree)
 
 ;;; VMS does something strange when output is sent to both
@@ -340,44 +304,82 @@
 ;;; translation if not opened in `b' mode.
 
 (define OPEN_READ (case (software-type)
-		    ((MS-DOS WINDOWS ATARIST) "rb")
-		    (else "r")))
+		    ((MS-DOS WINDOWS ATARIST) 'rb)
+		    (else 'r)))
 (define OPEN_WRITE (case (software-type)
-		     ((MS-DOS WINDOWS ATARIST) "wb")
-		     (else "w")))
+		     ((MS-DOS WINDOWS) 'wbc)
+		     ((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 (_TRACKED mode) (string-append mode "?"))
+		    ((MS-DOS WINDOWS) 'r+bc)
+		    ((ATARIST) 'r+b)
+		    (else 'r+)))
+(define ((make-moder str) mode)
+  (if (symbol? mode)
+      (string->symbol (string-append (symbol->string mode) str))
+      (string-append mode str)))
+(define _IONBF (make-moder "0"))
+(define _TRACKED (make-moder "?"))
+(define _EXCLUSIVE (make-moder "x"))
 
 (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 (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 (string-index str chr)
+  (define len (string-length str))
+  (do ((pos 0 (+ 1 pos)))
+      ((or (>= pos len) (char=? chr (string-ref str pos)))
+       (and (< pos len) pos))))
+
+(if (not (defined? try-create-file))
+(define (try-create-file str modes . perms)
+  (if (symbol? modes) (set! modes (symbol->string modes)))
+  (let ((idx (string-index modes #\x)))
+    (cond ((require:feature->path 'i/o-extensions)
+	   (require 'i/o-extensions)
+	   (apply try-create-file str modes perms))
+	  ((not idx)
+	   (warn "not exclusive modes?" modes str)
+	   (try-open-file str modes))
+	  (else (set! modes (string-append (substring modes 0 idx)
+					   (substring modes (+ 1 idx)
+						      (string-length modes))))
+		(cond ((not (string-index modes #\w))
+		       (warn 'try-create-file "not writing?" modes str)
+		       (try-open-file str modes))
+		      (else
+		       (cond ((and (not (null? perms))
+				   (not (eqv? #o666 (car perms))))
+			      (warn "perms?" (car perms) str)))
+		       (cond ((file-exists? str) #f)
+			     (else (try-open-file str modes))))))))))
 
 (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)
+(define (call-with-open-ports . ports)
+  (define proc (car ports))
+  (cond ((procedure? proc) (set! ports (cdr ports)))
+	(else (set! ports (reverse ports))
+	      (set! proc (car ports))
+	      (set! ports (reverse (cdr ports)))))
+  (let ((ans (apply proc ports)))
+    (for-each close-port ports)
     ans))
 
+(define (call-with-input-file str proc)
+  (call-with-open-ports (open-input-file str) proc))
+
 (define (call-with-output-file str proc)
-  (let* ((file (open-output-file str))
-	 (ans (proc file)))
-    (close-output-port file)
-    ans))
+  (call-with-open-ports (open-output-file str) proc))
 
 (define (with-input-from-port port thunk)
   (dynamic-wind (lambda () (set! port (set-current-input-port port)))
@@ -412,8 +414,34 @@
     (close-port nport)
     ans))
 
+(define (call-with-outputs thunk proc)
+  (define stdout #f)
+  (define stderr #f)
+  (define status #f)
+  (set! stdout
+	(call-with-output-string
+	 (lambda (stdout)
+	   (set! stderr
+		 (call-with-output-string
+		  (lambda (stderr)
+		    (call-with-current-continuation
+		     (lambda (escape)
+		       (dynamic-wind
+			   (lambda ()
+			     (set! status #f)
+			     (set! stdout (set-current-output-port stdout))
+			     (set! stderr (set-current-error-port stderr)))
+			   (lambda () (set! status (list (thunk))))
+			   (lambda ()
+			     (set! stdout (set-current-output-port stdout))
+			     (set! stderr (set-current-error-port stderr))
+			     (if (not status) (escape #f))))))))))))
+  (apply proc stdout stderr (or status '())))
+
 (define (warn . args)
   (define cep (current-error-port))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
   (perror "WARN")
   (errno 0)
   (display "WARN: " cep)
@@ -426,6 +454,8 @@
 
 (define (error . args)
   (define cep (current-error-port))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
   (perror "ERROR")
   (errno 0)
   (display "ERROR: " cep)
@@ -446,15 +476,22 @@
   (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
   (newline)
   result)
+(define (pprint . args)
+  (define result #f)
+  (for-each (lambda (x) (set! result x) (pretty-print x)) args)
+  result)
 (define (pp . args)
   (for-each pretty-print args)
   (if #f #f))
 
+(if (not (defined? file-exists?))
 (define (file-exists? str)
   (let ((port (open-file str OPEN_READ)))
-    (and port (close-port port) #t)))
+    (errno 0)
+    (and port (close-port port) #t))))
 (define (file-readable? str)
   (let ((port (open-file str OPEN_READ)))
+    (errno 0)
     (and port
 	 (char-ready? port)
 	 (do ((c (read-char port)
@@ -467,22 +504,20 @@
 (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? ed))
+(define (ed . args)
+  (system (apply string-append
+		 (or (getenv "EDITOR") "ed")
+		 (map (lambda (s) (string-append " " s)) args)))))
 
 (if (not (defined? output-port-width))
-    (define (output-port-width . arg) 80))
+(define (output-port-width . arg) 80))
 
 (if (not (defined? output-port-height))
-    (define (output-port-height . arg) 24))
+(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 (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
 
 (define slib:error error)
 (define slib:warn warn)
@@ -490,7 +525,9 @@
 (define slib:form-feed #\page)
 (define slib:eval eval)
 
-;;; Load.
+(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep)))
+
+;;;; Load.
 (define load:indent 0)
 (define (load:pre file)
   (define cep (current-error-port))
@@ -513,12 +550,19 @@
 	 (newline cep)
 	 (force-output cep))))
 
+;;; Here for backward compatibility
+(define scheme-file-suffix
+  (case (software-type)
+    ((NOSVE) (lambda () "_scm"))
+    (else (lambda () ".scm"))))
+
 (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 *load-reader* #f)
 (define (scm:load file . libs)
   (define filesuf file)
   (define hss (has-suffix? file (scheme-file-suffix)))
@@ -531,11 +575,11 @@
 			   (fs2 (file-readable? fs)))
 		      (and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
 		      ))))
-      (and (null? libs) (try-load file))
+      (and (null? libs) (try-load file *load-reader*))
       ;;HERE is where the suffix gets specified
       (and (not hss) (errno 0)		; clean up error from TRY-LOAD above
 	   (set! filesuf (string-append file (scheme-file-suffix)))
-	   (try-load filesuf))
+	   (try-load filesuf *load-reader*))
       (and (procedure? could-not-open) (could-not-open) #f)
       (begin (set! load:indent 0)
 	     (error "LOAD couldn't find file " file)))
@@ -547,88 +591,335 @@
   (define sfs (scheme-file-suffix))
   (define filesuf file)
   (load:pre file)
-  (or (and (or (try-load file)
+  (or (and (or (try-load file *load-reader*)
 	       ;;HERE is where the suffix gets specified
 	       (and (not (has-suffix? file sfs))
 		    (begin (set! filesuf (string-append file sfs))
-			   (try-load filesuf)))))
+			   (try-load filesuf *load-reader*)))))
       (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)
 
+;;; This is the vicinity where this file resides.
+(define implementation-vicinity #f)
+
+;;; (library-vicinity) should be defined to be the pathname of the
+;;; directory where files of Scheme library functions reside.
+(define library-vicinity #f)
+
+;;; (home-vicinity) should return the vicinity of the user's HOME
+;;; directory, the directory which typically contains files which
+;;; customize a computer environment for a user.
+(define home-vicinity #f)
+
+(define (login->home-directory login)
+  (cond ((defined? getpw)
+	 (let ((pwvect (getpw login)))
+	   (and pwvect (vector-ref pwvect 5))))
+	((not (file-exists? "/etc/passwd")) #f)
+	(else
+	 (call-with-input-file "/etc/passwd"
+	   (lambda (iprt)
+	     (require 'string-search)
+	     (require 'line-i/o)
+	     (let tryline ()
+	       (define line (read-line iprt))
+	       (define (get-field)
+		 (define idx (string-index line #\:))
+		 (and idx
+		      (let ((fld (substring line 0 idx)))
+			(set! line (substring line (+ 1 idx)
+					      (string-length line)))
+			fld)))
+	       (cond ((eof-object? line) #f)
+		     ((string-index line #\:)
+		      => (lambda (idx)
+			   (define name (substring line 0 idx))
+			   (cond ((equal? login name)
+				  (do ((ans (get-field) (get-field))
+				       (cnt 4 (+ -1 cnt)))
+				      ((or (negative? cnt) (not ans)) ans)))
+				 (else (tryline))))))))))))
+
+(if (not (defined? getlogin))
+(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))))
+
+;;; 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 (set-vicinities! init-file)
+  (set! implementation-vicinity
+	(let ((vic (pathname->vicinity init-file)))
+	  (lambda () vic)))
+  (set! library-vicinity
+	(let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
+	  (if library-path
+	      (lambda () library-path)
+	      (lambda ()
+		(let ((olv library-vicinity)
+		      (oload load))
+		  (dynamic-wind
+		      (lambda () (set! load identity))
+		      (lambda ()
+			(let ((filename (in-vicinity (implementation-vicinity)
+						     "require.scm")))
+			  (or (try-load filename)
+			      (try-load (in-vicinity (implementation-vicinity)
+						     "requires.scm"))
+			      (error "Can't load" filename))))
+		      (lambda () (set! load oload)))
+		  (if (eq? olv library-vicinity)
+		      (error "Can't find library-vicinity"))
+		  (library-vicinity))))))
+  (set! home-vicinity
+	(let ((home (getenv "HOME")))
+	  (and (not home) login->home-directory
+	       (let ((login (getlogin)))
+		 (and login (set! home (login->home-directory login)))))
+	  (and home
+	       (case (software-type)
+		 ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME
+		  (if (not
+		       (eqv? #\/ (string-ref home (+ -1 (string-length home)))))
+		      (set! home (string-append home "/"))))))
+	  (lambda () home))))
+;;; SET-VICINITIES! is also called from BOOT-TAIL
+(set-vicinities! *load-pathname*)
+
+;;;; Initialize SLIB
 (load (in-vicinity (library-vicinity) "require"))
 
-;;; DO NOT MOVE!  This must be done after "require.scm" is loaded.
-(define slib:load-source scm:load-source)
-(define slib:load scm:load)
+;;; This turns off line-numbering off for SLIB loads.
+(define *slib-load-reader* (and (defined? read-numbered) read-numbered))
+
+;;; DO NOT MOVE!  SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after
+;;; "require.scm" is loaded.
+(define (slib:load-source file . libs)
+  (fluid-let ((*load-reader* *slib-load-reader*))
+    (apply scm:load file libs)))
+(define (slib:load file . libs)
+  (fluid-let ((*load-reader* *slib-load-reader*))
+    (apply scm:load file libs)))
 
+;;; Dynamic link-loading
 (cond ((or (defined? dyn:link)
-	   (defined? vms:dynamic-link-call)
-	   (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
+	   (defined? vms:dynamic-link-call))
        (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 (slib:load-compiled . args)
+  (cond ((symbol? (car args))
+	 (require:require (car args))
+	 (apply slib:load-compiled (cdr args)))
+	((apply link:link args))
+	(else (error "Couldn't link files " args))))
+(provide 'compiled)))
+
+;;; Complete the function set for feature STRING-CASE.
+(cond
+ ((defined? string-upcase!)
 (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 string-ci->symbol
-  (if (equal? "a" (symbol->string 'a))
-      (lambda (str) (string->symbol (string-downcase str)))
-      (lambda (str) (string->symbol (string-upcase 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:integer-expt integer-expt)
-
-(define logical:bit-field bit-field)
-(define bit-extract bit-field)
-(define logical:bitwise-if bitwise-if)
-(define logical:copy-bit copy-bit)
-(define logical:copy-bit-field copy-bit-field)
-
-(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):
+  (let ((s2cis (if (equal? "x" (symbol->string 'x))
+		   string-downcase string-upcase)))
+    (lambda (str) (string->symbol (s2cis str)))))
+(define symbol-append
+  (let ((s2cis (if (equal? "x" (symbol->string 'x))
+		   string-downcase string-upcase)))
+    (lambda args
+      (string->symbol
+       (apply string-append
+	      (map
+	       (lambda (obj)
+		 (cond ((string? obj) (s2cis obj))
+		       ((number? obj) (s2cis (number->string obj)))
+		       ((symbol? obj) (symbol->string obj))
+		       ((not obj) "")
+		       (else (slib:error 'wrong-type-to 'symbol-append obj))))
+	       args))))))
+(define (StudlyCapsExpand nstr . delimitr)
+  (set! delimitr
+	(cond ((null? delimitr) "-")
+	      ((char? (car delimitr)) (string (car delimitr)))
+	      (else (car delimitr))))
+  (do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
+      ((> 1 idx) nstr)
+    (cond ((and (> idx 1)
+		(char-upper-case? (string-ref nstr (+ -1 idx)))
+		(char-lower-case? (string-ref nstr idx)))
+	   (set! nstr
+		 (string-append (substring nstr 0 (+ -1 idx))
+				delimitr
+				(substring nstr (+ -1 idx)
+					   (string-length nstr)))))
+	  ((and (char-lower-case? (string-ref nstr (+ -1 idx)))
+		(char-upper-case? (string-ref nstr idx)))
+	   (set! nstr
+		 (string-append (substring nstr 0 idx)
+				delimitr
+				(substring nstr idx
+					   (string-length nstr))))))))
+(provide 'string-case)))
+
+;;;; Bit order and lamination
+
+(define (bit-reverse k n)
+  (do ((m (if (negative? n) (lognot n) n) (ash m -1))
+       (k (+ -1 k) (+ -1 k))
+       (rvs 0 (logior (ash rvs 1) (logand 1 m))))
+      ((negative? k) (if (negative? n) (lognot rvs) rvs))))
+
+(define (integer->list k . len)
+  (if (null? len)
+      (do ((k k (ash k -1))
+	   (lst '() (cons (odd? k) lst)))
+	  ((<= k 0) lst))
+      (do ((idx (+ -1 (car len)) (+ -1 idx))
+	   (k k (ash k -1))
+	   (lst '() (cons (odd? k) lst)))
+	  ((negative? idx) lst))))
+
+(define (list->integer bools)
+  (do ((bs bools (cdr bs))
+       (acc 0 (+ acc acc (if (car bs) 1 0))))
+      ((null? bs) acc)))
+(define (booleans->integer . bools)
+  (list->integer bools))
+
+(define (bitwise:laminate . ks)
+  (define nks (length ks))
+  (define nbs (apply max (map integer-length ks)))
+  (do ((kdx (+ -1 nbs) (+ -1 kdx))
+       (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks))
+		 (ash ibs nks))))
+      ((negative? kdx) ibs)))
+
+(define (bitwise:delaminate count k)
+  (define nbs (* count (+ 1 (quotient (integer-length k) count))))
+  (do ((kdx (- nbs count) (- kdx count))
+       (lst (vector->list (make-vector count 0))
+	    (map (lambda (k bool) (+ (if bool 1 0) (ash k 1)))
+		 lst
+		 (integer->list (ash k (- kdx)) count))))
+      ((negative? kdx) lst)))
+
+;;;; Gray-code
+
+(define (integer->gray-code k)
+  (logxor k (ash k -1)))
+
+(define (gray-code->integer k)
+  (if (negative? k)
+      (error 'gray-code->integer 'negative? k)
+      (do ((ktmp k (ash ktmp -1))
+	   (ans 0 (logxor ans ktmp)))
+	  ((zero? ktmp) ans))))
+
+(define (grayter k1 k2)
+  (define kl1 (integer-length k1))
+  (define kl2 (integer-length k2))
+  (cond ((eqv? kl1 kl2) (> (gray-code->integer k1) (gray-code->integer k2)))
+	(else (> kl1 kl2))))
+
+(define (gray-code<? k1 k2)
+  (not (or (eqv? k1 k2) (grayter k1 k2))))
+(define (gray-code<=? k1 k2)
+  (or (eqv? k1 k2) (not (grayter k1 k2))))
+(define (gray-code>? k1 k2)
+  (and (not (eqv? k1 k2)) (grayter k1 k2)))
+(define (gray-code>=? k1 k2)
+  (or (eqv? k1 k2) (grayter k1 k2)))
+
+(define @case-aux
+  (let ((integer-jump-table 1)
+	(char-jump-table 2))
+    (lambda (keys actions else-action)
+      (let ((n (length keys)))
+	(define (every-key pred)
+	  (let test ((keys keys))
+	    (or (null? keys)
+		(and (pred (car keys)) (test (cdr keys))))))
+	(define (jump-table keys)
+	  (let ((minkey (apply min keys))
+		(maxkey (apply max keys)))
+	    (and (< (- maxkey minkey) (* 4 n))
+		 (let ((actv (make-vector
+			      (+ 2 (- maxkey minkey)) else-action)))
+		   (for-each
+		    (lambda (key action)
+		      (vector-set! actv (+ 1 (- key minkey)) action))
+		    keys actions)
+		   (list integer-jump-table minkey actv)))))
+	(cond ((< n 5) #f)
+	      ((every-key integer?)
+	       (jump-table keys))
+	      ((every-key char?)
+	       (let* ((int-keys (map char->integer keys)))
+		 (cond ((jump-table int-keys) =>
+			(lambda (x)
+			  (cons char-jump-table
+				(cons (integer->char (cadr x))
+				      (cddr x)))))
+		       (else #f)))))))))
+
+;;;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
+     (lambda (exp env)
+       (@copy-tree (apply f (remove-line-numbers! (cdr exp))))))))
+
+(define defmacro:get-destructuring-bind-pairs
+  (lambda (s e)
+    (let loop ((s s) (e e) (r '()))
+      (cond ((pair? s)
+	     (loop (car s) `(car ,e)
+		   (loop (cdr s) `(cdr ,e) r)))
+	    ((null? s) r)
+	    ((symbol? s) (cons `(,s ,e) r))
+	    (else (error 'destructuring-bind "illegal syntax"))))))
+
+(defsyntax destructuring-bind
+  (let ((destructuring-bind-transformer
+	 (lambda (s x . ff)
+	   (let ((tmp (gentemp)))
+	     `(let ((,tmp ,x))
+		(let ,(defmacro:get-destructuring-bind-pairs s tmp)
+		  ,@ff))))))
+    (set! *defmacros*
+	  (acons 'destructuring-bind
+		 destructuring-bind-transformer *defmacros*))
+    (defmacro:transformer destructuring-bind-transformer)))
+
+(defsyntax defmacro:simple-defmacro
   (let ((defmacro-transformer
 	  (lambda (name parms . body)
-	    `(define ,name
+	    `(defsyntax ,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)))
 
+(defmacro:simple-defmacro defmacro (name . body)
+  (define (expn name pattern body)
+    (let ((args (gentemp)))
+      `(defmacro:simple-defmacro ,name ,args
+	 (destructuring-bind ,pattern ,args ,@body))))
+  (if (pair? name)
+      (expn (car name) (cdr name) body)
+      (expn name (car body) (cdr body))))
+
 (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))
+			 (if a (apply (cdr a) (cdr e)) e))
 			(else e)))
       e))
 
@@ -662,15 +953,15 @@
 	  (evl o))
 	(set! *load-pathname* old-load-pathname)))))
 
-;;; Autoloads for SLIB procedures.
+;;;; 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))
+(define (track-all . args) (require 'debug) (apply track-all args))
+(define (stack-all . args) (require 'debug) (apply stack-all args))
+(define (break-all . args) (require 'debug) (apply break-all args))
+(define (pretty-print . args) (require 'pretty-print) (apply pretty-print args))
 
-;; (require 'transcript) would get us SLIB transcript -- not what we want.
+;;; (require 'transcript) would get us SLIB transcript -- not what we want.
 (define (transcript-on arg)
   (load (in-vicinity (implementation-vicinity)
 		     (string-append "Tscript" (scheme-file-suffix))))
@@ -678,15 +969,13 @@
 (define (transcript-off)
   (error "No transcript active"))
 
-;;; Macros.
+;;;; 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))))
+;;; Trace gets re-defmacroed when tracef autoloads.
+(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x))))
+(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x))))
+(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x))))
+(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x))))
 
 (defmacro defvar (var val)
   `(if (not (defined? ,var)) (define ,var ,val)))
@@ -698,7 +987,7 @@
 		    (else (slib:error 'trying-to-defconst name
 				      'to-different-value value)))
 	      `(define ,name ,value))))
-(defmacro casev (key . clauses)
+(defmacro qase (key . clauses)
   `(case ,key
      ,@(map (lambda (clause)
 	      (if (list? (car clause))
@@ -714,6 +1003,7 @@
 			(cdr clause))
 		  clause))
 	    clauses)))
+(defmacro (casev . args) `(qase ,@args))
 
 (defmacro fluid-let (clauses . body)
   (let ((ids (map car clauses))
@@ -751,30 +1041,35 @@
 (cond
  ((defined? stack-trace)
 
-  #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
-  (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))
+  ;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
+(define (error . args)
+  (define cep (current-error-port))
+  (if (defined? print-call-stack)
+      (print-call-stack cep))
+  (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)
+  (if (defined? print-call-stack)
+      (print-call-stack 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.
@@ -787,30 +1082,48 @@
        (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)
-	(let ((dims (array-dimensions a)))
-	  (if (pair? dims)
-	      (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
-		   dims)
-	      dims)))))
+(begin
+
+(define (array-null? array)
+  (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
+		       (array-shape array)))))
+(define (create-array prot . args)
+  (if (array-null? prot)
+      (dimensions->uniform-array args (array-prototype prot))
+      (dimensions->uniform-array args (array-prototype prot)
+				 (apply array-ref prot
+					(map car (array-shape prot))))))
+(define (make-array initial-value . dimensions)
+  (apply create-array (vector initial-value) dimensions))
+(define (make-uniform-wrapper prot)
+  (if (string? prot) (set! prot (string->number prot)))
+  (if prot
+      (lambda opt (if (null? opt)
+		      (list->uniform-array 1 prot '())
+		      (list->uniform-array 0 prot (car opt))))
+      vector))
+(define Ac64 (make-uniform-wrapper "+64i"))
+(define Ac32 (make-uniform-wrapper "+32i"))
+(define Ar64 (make-uniform-wrapper "64."))
+(define Ar32 (make-uniform-wrapper "32."))
+(define As64 (make-uniform-wrapper -64))
+(define As32 (make-uniform-wrapper -32))
+(define As16 (make-uniform-wrapper -16))
+(define As8  (make-uniform-wrapper -8))
+(define Au64 (make-uniform-wrapper  64))
+(define Au32 (make-uniform-wrapper  32))
+(define Au16 (make-uniform-wrapper  16))
+(define Au8  (make-uniform-wrapper  8))
+(define At1  (make-uniform-wrapper  #t))
+
+(define (array-shape a)
+  (let ((dims (array-dimensions a)))
+    (if (pair? dims)
+	(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+	     dims)
+	dims)))
+(define array=? equal?)
+))
 
 (define (alarm-interrupt) (alarm 0))
 (if (defined? setitimer)
@@ -842,8 +1155,8 @@
 ;;; if it wants to alter the arguments which BOOT-TAIL processes.
 (define *argv* #f)
 
-(if (not (defined? *R4RS-macro*))
-    (define *R4RS-macro* #f))
+(if (not (defined? *syntax-rules*))
+    (define *syntax-rules* #f))
 (if (not (defined? *interactive*))
     (define *interactive* #f))
 
@@ -866,9 +1179,14 @@
       (member "-no-init-file" (program-arguments))
       (member "--no-init-file" (program-arguments))
       (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
-			     (string-append "ScmInit") (scheme-file-suffix)))
+			     (string-append "ScmInit") (scheme-file-suffix))
+		*load-reader*)
       (errno 0))
 
+  ;; Include line numbers in loaded code.
+  (if (defined? read-numbered)
+      (set! *load-reader* read-numbered))
+
   (cond
    ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
     (require 'getopt)
@@ -877,12 +1195,12 @@
 ;;;  (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"))
+    (let* ((simple-opts "muvqibs")
+	   (arg-opts '("a kbytes" "-version" "-help"
+		       "no-init-file" "-no-init-file" "p number"
+		       "h feature" "r feature" "d filename"
+		       "f filename" "l filename"
+		       "c string" "e string" "o filename"))
 	   (opts (apply string-append ":" simple-opts
 			(map (lambda (o)
 			       (string-append (string (string-ref o 0)) ":"))
@@ -898,27 +1216,27 @@
 	    (thunk)
 	    (let ((complete #f))
 	      (dynamic-wind
-	       (lambda () #f)
-	       (lambda ()
-		 (thunk)
-		 (set! complete #t))
-	       (lambda ()
-		 (if (not complete) (close-port (current-input-port))))))))
+		  (lambda () #f)
+		  (lambda ()
+		    (thunk)
+		    (set! complete #t))
+		  (lambda ()
+		    (if (not complete) (close-port (current-input-port))))))))
 
       (define (do-string-arg)
 	(require 'string-port)
 	(do-thunk
 	 (lambda ()
-	   ((if *R4RS-macro* macro:eval eval)
+	   ((if *syntax-rules* macro:eval eval)
 	    (call-with-input-string
-	     (string-append "(begin " *optarg* ")")
-	     read))))
+		(string-append "(begin " *optarg* ")")
+	      read))))
 	(set! didsomething #t))
 
       (define (do-load file)
 	(do-thunk
 	 (lambda ()
-	   (cond (*R4RS-macro* (require 'macro) (macro:load file))
+	   (cond (*syntax-rules* (require 'macro) (macro:load file))
 		 (else (load file)))))
 	(set! didsomething #t))
 
@@ -938,7 +1256,7 @@
 	 (lambda (o)
 	   (display (string-append " [-" o "]") cep)
 	   (set! i (+ 1 i))
-	   (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
+	   (cond ((zero? (modulo i 5)) (newline cep) (display indent cep))))
 	 (cdr arg-opts))
 	(display " [-- | -s | -] [file] [args...]" cep) (newline cep)
 	(if success? (display success? cep) (quit #f)))
@@ -946,14 +1264,15 @@
       ;; -a int => ignore (handled by scm_init_from_argv)
       ;; -c str => (eval str)
       ;; -e str => (eval str)
-      ;; -d str => (require 'database-utilities) (open-database str)
+      ;; -d str => (require 'databases) (open-database str)
       ;; -f str => (load str)
       ;; -l str => (load str)
-      ;; -r str => (require str)
+      ;; -r sym => (require sym)
+      ;; -h sym => (provide sym)
       ;; -o str => (dump str)
       ;; -p int => (verbose int)
-      ;; -m     => (set! *R4RS-macro* #t)
-      ;; -u     => (set! *R4RS-macro* #f)
+      ;; -m     => (set! *syntax-rules* #t)
+      ;; -u     => (set! *syntax-rules* #f)
       ;; -v     => (verbose 3)
       ;; -q     => (verbose 0)
       ;; -i     => (set! *interactive* #t)
@@ -977,46 +1296,44 @@
 			 (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*))
+	  ((#\d) (require 'databases)
+	   (open-database *optarg*))
 	  ((#\o) (require 'dump)
-		 (if (< *optind* (length *argv*))
-		     (dump *optarg* #t)
-		     (dump *optarg*)))
+	   (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 'values)
-					  (require 'macro)
-					  (require 'eval)
-					  (set! *R4RS-macro* #t))
+				   ((#\2) (require 'r2rs))
+				   ((#\3) (require 'r3rs))
+				   ((#\4) (require 'r4rs))
+				   ((#\5) (require 'r5rs)
+				    (set! *syntax-rules* #t))
 				   (else (require (string->symbol *optarg*))))
 				 (require (string->symbol *optarg*))))))
+	  ((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*)))))
 	  ((#\p) (verbose (string->number *optarg*)))
 	  ((#\q) (verbose 0))
 	  ((#\v) (verbose 3))
 	  ((#\i) (set! *interactive* #t) ;sh-like
-		 (verbose (max 2 (verbose))))
+	   (verbose (max 2 (verbose))))
 	  ((#\b) (set! didsomething #t)
-		 (set! *interactive* #f))
+	   (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))
+	   (set! didsomething #t)
+	   (set! *interactive* #t))
+	  ((#\m) (set! *syntax-rules* #t))
+	  ((#\u) (set! *syntax-rules* #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*)))))
+	   (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))
@@ -1076,7 +1393,7 @@ There is no warranty, to the extent permitted by law.
 	       (set! *interactive* #t)))))
 
     (cond ((not *interactive*) (quit))
-	  ((and *R4RS-macro* (not (provided? 'macro)))
+	  ((and *syntax-rules* (not (provided? 'macro)))
 	   (require 'repl)
 	   (require 'macro)
 	   (let* ((oquit quit))
diff --git a/Link.scm b/Link.scm
index c34d56e..0bed48e 100644
--- a/Link.scm
+++ b/Link.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 2002 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
@@ -15,160 +15,114 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, 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.
+;;;; "Link.scm", Dynamic linking/loading code for SCM.
 ;;; Author: Aubrey Jaffer.
 
-;;; 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 'hobbit)
-      (apply hobbit args)))
-
-(define (compile-file file . args)
-  (apply hobbit file args)
-  (load (in-vicinity (implementation-vicinity) "build"))
-  (build-from-whole-argv
-   (list "build" "-tdll"
-	 (string-append "--compiler-options=-I" (implementation-vicinity))
-	 "-c"
-	 (begin (require 'glob)
-		((filename:substitute?? (scheme-file-suffix) ".c") file))
-	 "-hsystem"
-	 )))
-
-(define link-named-scm
-  (let ((scm:object-suffix (case (software-type)
-			     ((MSDOS VMS) ".obj")
-			     (else ".o"))))
-    (lambda (name . modules)
-      (load (in-vicinity (implementation-vicinity) "build"))
-      (let* ((iv (implementation-vicinity))
-	     (oss (string-append scm:object-suffix " "))
-	     (command
-	      (append
-	       (list "build" "--type=exe" "-cscm.c" "-hsystem"
-		     ;; "-F" "compiled-closure" "inexact"
-		     (string-append "--linker-options=-L"
-				    (implementation-vicinity)))
-	       (map (lambda (n) (string-append "-iinit_" n)) modules)
-	       (list
-		(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")
-	  ((provided? 'mac-dl) ".shlb")
-	  (else ".o")))
-  (define link:link
-    (lambda (file . libs)
-      (define oloadpath *load-pathname*)
-      (let* ((sl (string-length file))
-	     (lasl (string-length link:able-suffix))
-	     (fname (let loop ((i (- sl 1)))
-		      (cond ((negative? i) file)
-			    ((vicinity:suffix? (string-ref file i))
-			     (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))))
-	(if (and (provided? 'sun-dl)
-		 (> 3 (string-length file))
-		 (not (eqv? (string-ref file 0) '#\/)))
-	    (set! file (string-append "./" file)))
-	(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)))))))
+(define link:able-suffix
+  (cond ((provided? 'shl) ".sl")
+	((provided? 'sun-dl) ".so")
+	((provided? 'mac-dl) ".shlb")
+	(else ".o")))
+(define (file->init_name name)
+  (string-append
+   "init_"
+   (list->string
+    (map (lambda (chr) (if (eqv? #\- chr) #\_ chr))
+	 (map char-downcase (string->list name))))))
+(define link:link
+  (lambda (file . libs)
+    (define oloadpath *load-pathname*)
+    (let* ((sl (string-length file))
+	   (lasl (string-length link:able-suffix))
+	   (fname (let loop ((i (- sl 1)))
+		    (cond ((negative? i) file)
+			  ((vicinity:suffix? (string-ref file i))
+			   (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)
+      (if (and (provided? 'sun-dl)
+	       (< 3 sl)
+	       (not (eqv? (string-ref file 0) '#\/)))
+	  (set! file (string-append "./" file)))
+      (set! linkobj (or (provided? 'sun-dl) (dyn:link file)))
+      (and linkobj
+	   (for-each (lambda (lib)
+		       (or (dyn:link lib) (slib:error "couldn't link: " lib)))
+		     libs))
+      (if (provided? 'sun-dl) (set! linkobj (dyn:link file)))
+      (cond ((not linkobj)
+	     (set! *load-pathname* oloadpath) #f)
+	    ((dyn:call (file->init_name name) linkobj)
+	     (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))
-	    ((vicinity:suffix? (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)))))
+(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))
+	  ((vicinity:suffix? (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 (file->init_name fil)))))
 
 (cond
  ((provided? 'sun-dl)
   ;; These libraries are (deferred) linked in conversion to ".so"
-  (define (usr:lib lib) #f)
-  (define (x:lib lib) #f))
+(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)))
+(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)))
  ((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")))
+(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? 'dld)
-  (define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
-  (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))
+(define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
+(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))
diff --git a/Macexp.scm b/Macexp.scm
new file mode 100644
index 0000000..6802699
--- /dev/null
+++ b/Macexp.scm
@@ -0,0 +1,586 @@
+;; Copyright (C) 1999 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, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of SCM.
+;;
+;; The exception is that, if you link the SCM 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 SCM 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 SCM.  If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; SCM, 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 SCM, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "Macexp.scm", macro expansion, respecting hygiene.
+;;; Author: Radey Shouman
+
+;; LLIST is a lambda list, BINDINGS an alist using the same identifiers.
+(define extended-environment
+  (let ((env:annotation-marker 4))
+    (lambda (llist bindings env)
+      (cons llist (cons env:annotation-marker (cons bindings env))))))
+
+(define syntax-extended-environment
+  (let ((env:syntax-marker 6))
+    ;;BINDINGS is an alist
+    (lambda (bindings env)
+      (cons (cons env:syntax-marker bindings) env))))
+
+(define (environment-ref env id)
+  (environment-annotation id env))
+
+;;(debind:if_ ?llist ?val ?body ?alt)
+;;?alt should evaluate to a procedure taking two arguments, a pattern
+;;and an object.  This macro requires the (... ...) ellipsis quote
+;;extension.
+(define-syntax debind:if
+  (syntax-rules ()
+    ((_ "PARSE LLIST" () ?val ?body ?alt)
+     (if (null? ?val) ?body (?alt '() ?val)))
+
+    ((_ "PARSE LLIST" (?pattern (... ...)) ?val ?body ?alt)
+     (let loop ((v ?val))
+       (cond ((null? v)
+	      (debind:if "PARSE ..." ?pattern ?val ?body))
+	     ((pair? v)
+	      (let ((carv (car v)))
+		(debind:if "PARSE LLIST" ?pattern carv
+			   (loop (cdr v)) ?alt)))
+	     (else
+	      (?alt '(?pattern (... ...)) ?val)))))
+
+    ((_ "PARSE LLIST" (?first . ?rest) ?val ?body ?alt)
+     (if (pair? ?val)
+	 (let ((carv (car ?val))
+	       (cdrv (cdr ?val)))
+	   (debind:if "PARSE LLIST" ?first carv
+		      (debind:if "PARSE LLIST" ?rest cdrv ?body ?alt)
+		      ?alt))
+	 (?alt '(?first . ?rest) ?val)))
+
+    ((_ "PARSE LLIST" ?name ?val ?body ?alt)
+     (let ((?name ?val)) ?body))
+
+    ((_ "PARSE ..." () ?val ?body)
+     ?body)
+
+    ((_ "PARSE ..." (?pattern (... ...)) ?val ?body)
+     (debind:if "PARSE ..." ?pattern ?val ?body))
+
+    ((_ "PARSE ..." (?first . ?rest) ?val ?body)
+     (debind:if "PARSE ..." ?first (map car ?val)
+	(debind:if "PARSE ..." ?rest (map cdr ?val)
+			    ?body)))
+
+    ((_ "PARSE ..." ?name ?val ?body)
+     (let ((?name ?val)) ?body))
+
+    ((_ ?llist ?val ?body)
+     (debind:if ?llist ?val ?body
+		(lambda (pat val "debind:if" '?llist val
+			     "does not match" pat))))
+
+    ((_ ?llist ?val ?body ?alt)
+     (let ((val ?val)
+	   (alt ?alt))
+       (debind:if "PARSE LLIST" ?llist val ?body alt)))))
+
+;; Uncomment for DESTRUCTURING-BIND enhanced with ellipsis (...) patterns.
+;(define-syntax destructuring-bind
+;  (syntax-rules ()
+;    ((_ ?llist ?val ?body1 ?body ...)
+;     (debind:if ?llist ?val
+;		(let () ?body1 ?body ...)
+;		(lambda (pat val)
+;		  (slib:error 'destructuring-bind '?llist
+;			      val "does not match" pat))))))
+
+;; This should really dispatch on the keyword only, then
+;; use destructuring-case for each keyword, that way errors
+;; may be more accurately reported for primitives.
+;;
+;;(keyword-case expr env (pattern body ...) ...)
+(define-syntax keyword-case
+  (syntax-rules (else)
+    ((_ "RECURSE" ?expr ?env)
+     (error 'keyword-case ?expr "not matched"))
+    ((_ "RECURSE" ?expr ?env
+	(else ?body1 ?body ...))
+     (let () ?body1 ?body ...))
+    ((_ "RECURSE" ?expr ?env
+	((?keyword . ?pattern) ?body1 ?body ...)
+	?clause ...)
+     (let ((alt (lambda (ignore1 ignore2)
+		  (keyword-case "RECURSE" ?expr ?env ?clause ...))))
+       ;;Keywords are renamed in the top-level environment for each
+       ;;comparison, this is wasteful and somewhat ugly.
+       (if (identifier-equal? (renamed-identifier '?keyword '())
+			      (car ?expr) ?env)
+	   (debind:if ?pattern (cdr ?expr)
+		      (let () ?body1 ?body ...)
+		      alt)
+	   (alt #f #f))))
+    ((_ ?expr ?env ?clause1 ?clause ...)
+     (let ((expr ?expr))
+       (if (or (not (pair? expr))
+	       (not (identifier? (car expr))))
+	   (error 'keyword-case expr "bad form")
+	   (keyword-case "RECURSE" expr ?env ?clause1 ?clause ...))))))
+
+;; This is still not safe when ENV has non-macro bindings in it.
+;; It could be made safe by rebuilding an equivalent environment,
+;; retaining values only for syntactic bindings.
+(define (macro:expand-syntax form env pretty? verbose?)
+  (define globals '())
+  (define shadowed-globals '())
+  (define top-lambda (renamed-identifier 'LAMBDA #f))
+  (define top-let (renamed-identifier 'LET #f))
+  (define top-let* (renamed-identifier 'LET* #f))
+  (define top-letrec (renamed-identifier 'LETREC #f))
+  (define top-arrow (renamed-identifier '=> #f))
+  (define top-else (renamed-identifier 'ELSE #f))
+  (define top-define (renamed-identifier 'DEFINE #f))
+  (define top-begin (renamed-identifier 'BEGIN #f))
+  (define (arrow? id env)
+    (and (identifier? id)
+	 (identifier-equal? id top-arrow env)))
+  (define (else? id env)
+    (and (identifier? id)
+	 (identifier-equal? id top-else env)))
+  (define (define? form env)
+    (and (list? form)			;FORM will have been expanded.
+	 (identifier? (car form))
+	 (identifier-equal? top-define (car form) env)))
+  (define (begin? form env)
+    (and (list? form)
+	 (identifier? (car form))
+	 (identifier-equal? (car form) top-begin env)))
+
+  (define locally-bound? environment-annotation)
+
+  (define pretty-name
+    (if pretty?
+	(letrec ((counter 0)
+		 (genname
+		  (lambda (sym)
+		    (set! counter (+ counter 1))
+		    (string->symbol
+		     (string-append (symbol->string sym)
+				    "|" (number->string counter))))))
+	  (lambda (name env)
+	    (if (symbol? name)
+		(if (or (memq name
+			      '(LAMBDA LET LET* LETREC DO DEFINE SET!
+				       BEGIN IF COND CASE AND OR QUOTE
+				       QUASIQUOTE UNQUOTE UNQUOTE-SPLICING
+				       DEFINE-SYNTAX LET-SYNTAX LETREC-SYNTAX
+				       SYNTAX-QUOTE ELSE =>))
+			(locally-bound? name env))
+		    (genname name)
+		    name)
+		(genname (identifier->symbol name)))))
+	identity))
+
+  ;; Local bindings -> (identifier pretty-name (usage-context ...))
+  ;; This will change.
+  (define (initial-binding name env)
+    (or (identifier? name)
+	(slib:error 'macro:expand name "not identifier"))
+    (list name (pretty-name name env) '()))
+  (define binding->name cadr)
+  (define binding->contexts caddr)
+  (define (binding-add-context! b context)
+    (let ((ctx (caddr b)))
+      (if (not (list? ctx))
+	  (error 'not-a-list ctx))
+      (or (memq context ctx)
+	  (set-car! (cddr b) (cons context ctx)))))
+
+  ;; Produces an alist
+  (define (llist->bindings llist env)
+    (let recurse ((ll llist))
+      (cond ((pair? ll)
+	     (cons (initial-binding (car ll) env)
+		   (recurse (cdr ll))))
+	    ((identifier? ll)
+	     (list (initial-binding ll env)))
+	    ((null? ll) ll)
+	    (else (error 'strange-lambda-list llist)))))
+
+  (define (expand-begin forms env context)
+    (if (null? forms)
+	'()
+	(let recurse ((forms forms))
+	  (if (null? (cdr forms))
+	      (list (expand (car forms) env context))
+	      (cons (expand (car forms) env 'SIDE-EFFECT)
+		    (recurse (cdr forms)))))))
+
+  (define (expand-body forms env context)
+    (define (rewrite forms defs)
+      (if (null? defs)
+	  (expand-begin forms env context)
+	  (list
+	   (expand-primitive
+	    `(,top-letrec ,(reverse defs) ;reverse just to make it pretty
+			  ,@forms) env context))))
+    (let loop ((forms forms)
+	       (defs '()))
+      (if (null? (cdr forms))
+	  (rewrite forms defs)
+	  (let ((form1 (expand (car forms) env 'SIDE-EFFECT)))
+	    (cond ((define? form1 env)
+		   (loop (cdr forms)
+			 (cons (cdr form1) defs)))
+		  ((begin? form1 env)
+		   (loop (append (cdr form1) (cdr forms))
+			 defs))
+		  (else (rewrite forms defs)))))))
+
+  (define (lookup id env)
+    (or (environment-ref env id)
+	(let* ((sym (identifier->symbol id))
+	       (binding (cond ((assq sym globals))
+			      (else
+			       (let ((b (initial-binding sym env)))
+				 (set! globals (cons b globals))
+				 b)))))
+	  (cond ((not pretty?) id)
+		((not (locally-bound? sym env)))
+		((assq sym shadowed-globals))
+		(else
+		 (set! shadowed-globals
+		       (cons (cons sym (binding->name binding))
+			     shadowed-globals))))
+	    binding)))
+
+  (define pretty-varref
+    (if pretty?
+	(lambda (id env)
+	  (if (symbol? id)
+	      id
+	      (let ((sym (identifier->symbol id)))
+		(if (identifier-equal? id sym env) sym id))))
+	(lambda (id env) id)))
+
+  (define unpaint
+    (if pretty?
+	(lambda (x)
+	  (cond ((symbol? x) x)
+		((identifier? x) (identifier->symbol x))
+		((pair? x) (cons (unpaint (car x)) (unpaint (cdr x))))
+		((vector? x) (let* ((n (vector-length x))
+				    (v (make-vector n)))
+			       (do ((i 0 (+ i 1)))
+				   ((>= i n) v)
+				 (vector-set! v i (unpaint (vector-ref x i))))))
+		(else x)))
+	identity))
+
+  (define (expand* forms env context)
+    (map (lambda (form) (expand form env context)) forms))
+
+  (define (expand-primitive form env context)
+    (define keyword (and (pair? form)
+			 (if pretty?
+			     (identifier->symbol (car form))
+			     (car form))))
+    (keyword-case
+     form env
+     ;;Binding forms
+     ((LAMBDA llist body1 body ...)
+      (let* ((bindings (llist->bindings llist env))
+	     (env (extended-environment llist bindings env))
+	     (body (expand-body (cons body1 body) env context))
+	     (llist (let recurse ((ll llist)
+				  (bl bindings))
+		      (cond ((null? ll) '())
+			    ((pair? ll) (cons (binding->name (car bl))
+					      (recurse (cdr ll) (cdr bl))))
+			    (else (binding->name  bl))))))
+	`(,keyword ,llist ,@body)))
+     ((LET ((names values) ...) body1 body ...)
+      (let* ((values (expand* values env 'VALUE))
+	     (bindings (llist->bindings names env))
+	     (env (extended-environment names bindings env))
+	     (body (expand-body (cons body1 body) env context)))
+	`(,keyword ,(map (lambda (b val) (list (binding->name b) val))
+			 bindings values)
+		   ,@body)))
+     ((LET name1 ((names values) ...) body1 body ...)
+      (expand `((,top-letrec
+		 ((,name1 (,(pretty-varref top-lambda env) ,names
+			   ,@(cons body1 body))))
+		 ,name1) ,@values)
+	      env context))
+     ((LETREC ((names values) ...) body1 body ...)
+      (let* ((bindings (llist->bindings names env))
+	     (env (extended-environment names bindings env))
+	     (values (expand* values env 'VALUE))
+	     (body (expand-body (cons body1 body) env context)))
+	`(,keyword ,(map (lambda (b val) (list (binding->name b) val))
+			 bindings values)
+		   ,@body)))
+     ((LET* ((names values) ...) body1 body ...)
+      (let recurse ((ns names)
+		    (vs values)
+		    (env env)
+		    (bs '()))
+	(if (null? ns)
+	    (let ((body (expand-body (cons body1 body) env context)))
+	      `(,keyword ,(reverse bs) ,@body))
+	    (let ((binding (initial-binding (car ns) env)))
+	      (recurse (cdr ns) (cdr vs)
+		       (extended-environment (car ns)
+					     (list binding)
+					     env)
+		       (cons (list (binding->name binding)
+				   (expand (car vs) env 'VALUE))
+			     bs))))))
+     ((DO ((names inits . steps) ...)
+	  (test exit ...)
+	  body ...)
+      (let* ((steps (map (lambda (name step)
+			   (if (null? step) name (car step)))
+			 names steps))
+	     (inits (expand* inits env 'VALUE))
+	     (bindings (llist->bindings names env))
+	     (env (extended-environment names bindings env))
+	     (steps (expand* steps env 'VALUE))
+	     (test (expand test env 'BOOLEAN))
+	     (exit (expand-begin exit env context))
+	     (body (expand-begin body env 'SIDE-EFFECT)))
+	`(,keyword
+	  ,(map (lambda (binding init step)
+		  (list (binding->name binding) init step))
+		bindings inits steps)
+	  ,(cons test exit)
+	  ,@body)))
+     ((DEFINE (name . llist) body ...)
+      (expand-primitive
+       `(,keyword ,name (,top-lambda ,llist ,@body)) env context))
+     ((DEFINE name value)
+      (cond ((null? env)		;Top level
+	     (binding-add-context! (lookup name env) 'DEFINE)
+	     `(,keyword ,(pretty-varref name env)
+			,(expand value env 'VALUE)))
+	    (else
+	     `(,keyword ,name ,value)))) ;Expansion will be done by expand-body.
+
+     ((SET! var value)
+      (let ((b (lookup var env)))
+	(binding-add-context! b 'SET!)
+	`(,keyword ,(binding->name b) ,(expand value env 'VALUE))))
+
+     ;;Non-binding forms
+     ((BEGIN body ...)
+      (let ((body (expand-begin body env context)))
+	(if (null? (cdr body))
+	    (car body)
+	    `(,keyword ,@body))))
+     ((IF test conseq . alt)
+      `(,keyword ,(expand test env 'BOOLEAN)
+		 ,(expand conseq env context)
+		 ,@(if (pair? alt)
+		       (list (expand (car alt) env context))
+		       '())))
+     ((COND (test exprs ...) ...)
+      `(,keyword
+	,@(map (lambda (test exprs)
+		 (cond ((null? exprs) (list (expand test env context)))
+		       ((arrow? (car exprs) env)
+			(list (expand test env 'VALUE)
+			      (pretty-varref top-arrow env)
+			      (expand (cadr exprs) env 'PROCEDURE)))
+		       ((else? test env)
+			(cons (pretty-varref top-else env)
+			      (expand-begin exprs env context)))
+		       (else
+			(cons (expand test env 'BOOLEAN)
+			      (expand-begin exprs env context)))))
+	       test exprs)))
+     ((CASE obj (datums exprs ...) ...)
+      `(,keyword ,(expand obj env 'VALUE)
+	,@(map (lambda (datums exprs)
+		 (cons (if (else? datums env)
+			   (pretty-varref datums env)
+			   (unpaint datums))
+		       (expand-begin exprs env context)))
+	       datums exprs)))
+     ((AND forms ...)
+      `(,keyword ,@(expand* forms env context)))
+     ((OR forms ...)
+      `(,keyword ,@(expand* forms env context)))
+
+     ;; Should unpaint synthetic identifiers
+     ((QUOTE obj)
+      `(,keyword ,(unpaint obj)))
+     ((QUASIQUOTE obj)
+      `(,keyword
+	,(let qexp ((obj obj)
+		    (depth 0))
+	   (cond ((not (pair? obj))
+		  (unpaint obj))
+		 ((identifier? (car obj))
+		  (let ((keyword (car obj)))
+		    (keyword-case
+		     obj env
+		     ((QUASIQUOTE arg)
+		      (list keyword (qexp arg (+ depth 1))))
+		     ((UNQUOTE arg)
+		      (list keyword
+			    (if (zero? depth)
+				(expand arg env context)
+				(qexp arg (- depth 1)))))
+		     ((UNQUOTE-SPLICING arg)
+		      (list keyword
+			    (if (zero? depth)
+				(expand arg env context)
+				(qexp arg (- depth 1)))))
+		     (else
+		      (cons (unpaint keyword) (qexp (cdr obj) depth))))))
+		 (else
+		  (cons (qexp (car obj) depth)
+			(qexp (cdr obj) depth)))))))
+     ((DEFINE-SYNTAX name def)
+      form)
+     ((LET-SYNTAX ((names defs) ...) body1 body ...)
+      (let* ((env (syntax-extended-environment '() env))
+	     (defs (map (lambda (name def)
+			  (cons name (eval-syntax def env)))
+			names defs))
+	     (env (syntax-extended-environment defs env))
+	     (body (expand-body (cons body1 body) env context)))
+	(if pretty?
+	    `(,(pretty-varref top-let env) () ,@body)
+	    `(,top-let* (,(list marker #f)) ,@body))))
+     ((LETREC-SYNTAX ((names defs) ...) body1 body ...)
+      (let* ((eframe (map (lambda (name) (cons name #f)) names))
+	     (env (syntax-extended-environment eframe env)))
+	(do ((ds defs (cdr ds))
+	     (ef eframe (cdr ef)))
+	    ((null? ds))
+	  (set-cdr! (car ef) (eval-syntax (car ds) env)))
+	(let ((body (expand-body (cons body1 body) env context)))
+	  (if pretty?
+	      `(,(pretty-varref top-let env) () ,@body)
+	      `(,top-let* (,(list marker #f)) ,@body)))))
+     ;;SCM extension
+     ((SYNTAX-QUOTE obj)
+      `(,keyword ,obj))
+     (else
+      (warn 'expand-syntax "Unexpected primitive syntax" form)
+      form)))
+
+  (define (handle-shadowed form env)
+    (if (define? form env)
+	(list (car form) (cadr form)
+	      (handle-shadowed (caddr form)))
+	`(,(pretty-varref top-let env)
+	  ,(map (lambda (s)
+		  (list (cdr s)
+			(if (environment-ref env (car s))
+			    (renamed-identifier (car s) #f)
+			    (car s))))
+		shadowed-globals)
+	  ,form)))
+
+  (define (expand form env context)
+    (cond
+     ((identifier? form)
+      (let ((expanded (@macroexpand1 form env)))
+	(cond ((eq? form expanded) form)
+	      ((not expanded)
+	       (let* ((b (lookup form env))
+		      (name (binding->name b)))
+		 (binding-add-context! b context)
+		 name))
+	      (else expanded))))
+     ((number? form) form)
+     ((char? form) form)
+     ((boolean? form) form)
+     ((null? form) form)
+     ((string? form) form)
+     ((list? form)
+      (if (identifier? (car form))
+	  (let ((expanded (@macroexpand1 form env)))
+	    (cond ((eq? expanded form)
+		   (expand-primitive form env context))
+		  ((not expanded)
+		   (cons (expand (car form) env 'PROCEDURE)
+			 (map (lambda (arg)
+				(expand arg env 'VALUE))
+			      (cdr form))))
+		  (else
+		   (expand expanded env context))))
+	  (cons (expand (car form) env 'PROCEDURE)
+		(expand* (cdr form) env 'VALUE))))
+     (else
+      (warn 'expand-syntax "Unexpected type of form" form)
+      form)))
+
+  (let ((res (expand form env 'TOP)))
+    (cond (verbose?
+	   (display "Globals: ")
+	   (pretty-print globals)
+	   (display "Shadowed Globals: ")
+	   (pretty-print shadowed-globals)))
+    (cond ((null? shadowed-globals) res)
+	  ((not (begin? res env)) (handle-shadowed res env))
+	  (else (cons (car res)
+		      (map (lambda (form)
+			     (handle-shadowed form env))
+			   (cdr res)))))))
+
+(define (macro:expand form . opt)
+  (macro:expand-syntax form '()
+		       (not (memq 'not-pretty opt))
+		       (memq 'verbose opt)))
+
+;; Debugging fodder.
+(begin
+  (define (read* filename)
+    (call-with-input-file filename
+      (lambda (p)
+	(let loop ((forms '()))
+	  (let ((form (read p)))
+	    (if (eof-object? form)
+		(cons 'BEGIN (reverse forms))
+		(loop (cons form forms))))))))
+  (define (expand-file filename . opt)
+    (apply macro:expand (read* filename) '() opt))
+  (define s (read*  (or *load-pathname* "Macexp.scm"))))
+
+
+;;; Local Variables:
+;;; mode:scheme
+;;; eval:(put 'destructuring-bind 'scheme-indent-function 1)
+;;; eval:(put 'destructuring-case 'scheme-indent-function 1)
+;;; End:
diff --git a/Macro.scm b/Macro.scm
index 0ddccc1..911098b 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -56,12 +56,19 @@
   ;; We keep local copies of these standard special forms, otherwise,
   ;; redefining them before they are memoized below can lead to
   ;; infinite recursion.
-  (@let-syntax ((lambda (the-macro lambda))
+  (let-syntax ((lambda (the-macro lambda))
+		(begin (the-macro begin))
+		(quote (the-macro quote))
 		(let (the-macro let))
-		(cond (the-macro cond))
-		(if (the-macro if))
+		(let* (the-macro let*))
+		(letrec (the-macro letrec))
 		(and (the-macro and))
-		(or (the-macro or)))
+		(or (the-macro or))
+		(delay (the-macro delay))
+		(do (the-macro do))
+		(case (the-macro case))
+		(cond (the-macro cond))
+		(quasiquote (the-macro quasiquote)))
     (let ((var-rtd (make-record-type '? '(name rank)))
 	  (e-pat-rtd (make-record-type '... '(pattern vars)))
 	  (rule-rtd (make-record-type 'rule '(pattern inserted template))))
@@ -83,7 +90,8 @@
       (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern))
       (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars))
 
-      (define rule (record-constructor rule-rtd '(pattern inserted template)))
+      (define make-rule
+	(record-constructor rule-rtd '(pattern inserted template)))
       (define rule->pattern (record-accessor rule-rtd 'pattern))
       (define rule->inserted (record-accessor rule-rtd 'inserted))
       (define rule->template (record-accessor rule-rtd 'template))
@@ -92,6 +100,12 @@
 	(if (null? y) x
 	    (append x y)))
 
+      (define (append-if pred x y)
+	(let recur ((x x))
+	  (cond ((null? x) y)
+		((pred (car x)) (cons (car x) (recur (cdr x))))
+		(else (recur (cdr x))))))
+
       (define ellipsis?
 	(let (($... (renamed-identifier '... #f)))
 	  (lambda (x env)
@@ -108,111 +122,130 @@
 		(duplicates? (cdr vars)))))
 
       (define (compile-pattern literals rule-exp env-def)
-	(let recur ((pat (cdar rule-exp))
-		    (vars '())
-		    (rank 0)
-		    (k (lambda (compiled vars)
-			 (let ((dup (duplicates? (map car vars))))
-			   (if dup
-			       (error
-				"syntax-rules: duplicate pattern variable:"
-				dup " in rule " rule-exp)))
-			 (apply rule
-				compiled
-				(rewrite-template
-				 (cadr rule-exp) vars env-def)))))
+	(define (compile1 pat vars rank ell? k)
 	  (cond ((null? pat)
 		 (k pat vars))
 		((identifier? pat)
-		 (let ((lit (memq pat literals)))
-		   (if lit
-		       (k (renamed-identifier pat env-def) vars)
-		       (let ((var (pattern-variable pat rank)))
-			 (k var (cons (cons pat var) vars))))))
-		((pair? pat)
-		 (if (and (pair? (cdr pat))
-			  (ellipsis? (cadr pat) env-def)
-			  (or (null? (cddr pat))
-			      (error "bad ellipsis:" pat)))
-		     (if (ellipsis? (car pat) env-def)
-			 (recur (car pat) vars rank k)
-			 (recur (car pat) '() (+ rank 1)
-				(lambda (comp1 vars1)
-				  (k (list
-				      (ellipsis-pattern comp1 (map cdr vars1)))
-				     (append2 vars1 vars)))))
-		     (recur (car pat) '() rank
-			    (lambda (comp1 vars1)
-			      (recur (cdr pat) vars rank
-				     (lambda (comp2 vars2)
-				       (k (cons comp1 comp2)
-					  (append2 vars1 vars2))))))))
+		 (if (or (memq pat literals)
+			 (and (not ell?) (ellipsis? pat env-def)))
+		     (k (renamed-identifier pat env-def) vars)
+		     (let ((var (pattern-variable pat rank)))
+		       (k var (cons (cons pat var) vars)))))
 		((vector? pat)
-		 (recur (vector->list pat) vars rank
-			(lambda (comp vars)
-			  (k (list->vector comp) vars))))
-		(else
-		 (k pat vars)))))
+		 (compile1 (vector->list pat) vars rank ell?
+			   (lambda (comp vars)
+			     (k (list->vector comp) vars))))
+		((not (pair? pat))
+		 (k pat vars))
+		((and ell? (ellipsis? (car pat) env-def))
+		 (or (and (pair? (cdr pat))
+			  (null? (cddr pat)))
+		     (error "bad ellipsis quote:" pat))
+		 (compile1 (cadr pat) vars rank #f k))
+		((and ell?
+		      (pair? (cdr pat))
+		      (ellipsis? (cadr pat) env-def))
+		 (or (null? (cddr pat))
+		     (error "bad ellipsis:" pat))
+		 (compile1
+		  (car pat) '() (+ rank 1) ell?
+		  (lambda (comp1 vars1)
+		    (k (list
+			(ellipsis-pattern comp1 (map cdr vars1)))
+		       (append2 vars1 vars)))))
+		(else ; pat is a pair
+		 (compile1
+		  (car pat) '() rank ell?
+		  (lambda (comp1 vars1)
+		    (compile1
+		     (cdr pat) vars rank ell?
+		     (lambda (comp2 vars2)
+		       (k (cons comp1 comp2)
+			  (append2 vars1 vars2)))))))))
+	(let ((pat (car rule-exp))
+	      (tmpl (cadr rule-exp)))
+	  (if (identifier? pat)
+	      (apply make-rule #f (rewrite-template tmpl '() env-def))
+	      (compile1
+	       (cdr pat) '() 0 #t
+	       (lambda (compiled vars)
+		 (let ((dup (duplicates? (map car vars))))
+		   (if dup
+		       (error
+			"syntax-rules: duplicate pattern variable:"
+			dup " in rule " rule-exp)
+		       (apply make-rule
+			      (cons #f compiled)
+			      (rewrite-template tmpl vars env-def)))))))))
 
       (define (rewrite-template template vars env-def)
-	(let recur ((tmpl template)
-		    (rank 0)
-		    (inserted '())
-		    (k (lambda (compiled inserted opened)
-			 (list inserted compiled))))
+	(let rewrite1 ((tmpl template)
+		       (rank 0)
+		       (inserted '())
+		       (ell? #t)
+		       (k (lambda (compiled inserted opened)
+			    (list inserted compiled))))
 	  (cond ((null? tmpl)
 		 (k tmpl '() '()))
 		((identifier? tmpl)
 		 (let ((v (assq tmpl vars)))
-		   (if v
-		       (cond ((= rank (pattern-variable->rank (cdr v)))
-			      (k (cdr v) '() (list (cdr v))))
-			     ((> rank (pattern-variable->rank (cdr v)))
-			      (k (cdr v) '() '()))
-			     (else
-			      (error "pattern variable rank mismatch:" tmpl
-				     " in " template)))
-		       (k tmpl (list tmpl) '()))))
-		((pair? tmpl)
-		 (if (and (pair? (cdr tmpl))
-			  (ellipsis? (cadr tmpl) env-def))
-		     (if (and (ellipsis? (car tmpl) env-def)
-			      (or (null? (cddr tmpl))
-				  (error "bad ellipsis:" tmpl)))
-			 ;; (... ...) escape
-			 (k (car tmpl) (list (car tmpl)) '())
-			 (recur (car tmpl) (+ rank 1) '()
-				(lambda (comp1 ins1 op1)
-				  (if (null? op1)
-				      (error "Bad ellipsis:"
-					     tmpl " in template " template))
-				  (recur (cddr tmpl) rank inserted
-					 (lambda (comp2 ins2 op2)
-					   (k (cons
-					       (ellipsis-pattern comp1 op1)
-					       comp2)
-					      (append2 ins1 ins2)
-					      (append2 op1 op2)))))))
-		     (recur (car tmpl) rank '()
-			    (lambda (comp1 ins1 op1)
-			      (recur (cdr tmpl) rank inserted
-				     (lambda (comp2 ins2 op2)
-				       (k (cons comp1 comp2)
-					  (append2 ins1 ins2)
-					  (append2 op1 op2))))))))
+		   (cond ((not v)
+			  (k tmpl (list tmpl) '()))
+			 ((zero? (pattern-variable->rank (cdr v)))
+			  (k (cdr v) '() '()))
+			 ((>= rank (pattern-variable->rank (cdr v)))
+			  (k (cdr v) '() (list (cdr v))))
+			 (else
+			  (error "pattern variable rank mismatch:" tmpl
+				 " in " template)))))
 		((vector? tmpl)
-		 (recur (vector->list tmpl) rank inserted
-			(lambda (compiled inserted opened)
-			  (k (list->vector compiled) inserted opened))))
-		(else
-		 (k tmpl '() '())))))
-
+		 (rewrite1
+		  (vector->list tmpl) rank inserted ell?
+		  (lambda (compiled inserted opened)
+		    (k (list->vector compiled) inserted opened))))
+		((not (pair? tmpl))
+		 (k tmpl '() '()))
+		((and ell? (ellipsis? (car tmpl) env-def))
+		 ;; (... ...) escape
+		 (or (and (pair? (cdr tmpl))
+			  (null? (cddr tmpl)))
+		     (error "Bad ellpsis quote:" tmpl
+			    " in template " template))
+		 (rewrite1 (cadr tmpl) rank inserted #f k))
+		((and ell?
+		      (pair? (cdr tmpl))
+		      (ellipsis? (cadr tmpl) env-def))
+		 (rewrite1
+		  (car tmpl) (+ rank 1) '() ell?
+		  (lambda (comp1 ins1 op1)
+		    (if (null? op1)
+			(error "Bad ellipsis:" tmpl
+			       " in template " template))
+		    (rewrite1
+		     (cddr tmpl) rank inserted ell?
+		     (lambda (comp2 ins2 op2)
+		       (k (cons (ellipsis-pattern comp1 op1)
+				comp2)
+			  (append2 ins1 ins2)
+			  (append-if (lambda (op)
+				       (> (pattern-variable->rank op)
+					  rank))
+				     op1 op2)))))))
+		(else ; tmpl is a pair
+		 (rewrite1
+		  (car tmpl) rank '() ell?
+		  (lambda (comp1 ins1 op1)
+		    (rewrite1
+		     (cdr tmpl) rank inserted ell?
+		     (lambda (comp2 ins2 op2)
+		       (k (cons comp1 comp2)
+			  (append2 ins1 ins2)
+			  (append2 op1 op2))))))))))
 
 ;;; Match EXP to RULE, returning alist of variable bindings or #f.
 
       (define (match rule exp env-use)
-	(let recur ((r (rule->pattern rule))
-		    (x (cdr exp)))
+	(define (match1 r x)
 	  (cond ((null? r)
 		 (and (null? x) '()))
 		((pair? r)
@@ -220,8 +253,8 @@
 		     (and
 		      (list? x)
 		      (let ((pat (ellipsis-pattern->pattern (car r))))
-			(let match1 ((x x)
-				     (vals '()))
+			(let match-list ((x x)
+					 (vals '()))
 			  (if (null? x)
 			      (if (null? vals)
 				  (map list (ellipsis-pattern->vars (car r)))
@@ -230,14 +263,14 @@
 					   (map (lambda (al)
 						  (map cdr al))
 						(reverse vals)))))
-			      (let ((val (recur pat (car x))))
+			      (let ((val (match1 pat (car x))))
 				(and val
-				     (match1 (cdr x) (cons val vals))))))))
+				     (match-list (cdr x) (cons val vals))))))))
 		     (and
 		      (pair? x)
-		      (let ((v1 (recur (car r) (car x))))
+		      (let ((v1 (match1 (car r) (car x))))
 			(and v1
-			     (let ((v2 (recur (cdr r) (cdr x))))
+			     (let ((v2 (match1 (cdr r) (cdr x))))
 			       (and v2 (append2 v1 v2))))))))
 		((identifier? r)		;literal
 		 (and (identifier? x) (identifier-equal? r x env-use) '()))
@@ -245,16 +278,30 @@
 		 (list (cons r x)))
 		((vector? r)
 		 (and (vector? x)
-		      (recur (vector->list r) (vector->list x))))
+		      (match1 (vector->list r) (vector->list x))))
 		(else
-		 (and (equal? r x) '())))))
+		 (and (equal? r x) '()))))
+	(let ((pat (rule->pattern rule)))
+	  (if (pair? pat)
+	      (and (pair? exp)
+		   (match1 (cdr pat) (cdr exp)))
+	      (if (pair? exp) #f '()))))
+
+      (define (substitute-in-template x-use rule vars env-def)
+	(define (length-error pats vals)
+	  (apply error
+		 "syntax-rules: pattern variable length mismatch:\n"
+		 x-use
+		 (map (lambda (name val)
+			`(,(pattern-variable->name
+			    name) -> ,val))
+		      pats vals)))
 
-      (define (substitute-in-template rule vars env-def)
 	(let ((ins (map (lambda (id)
 			  (cons id (renamed-identifier id env-def)))
 			(rule->inserted rule))))
-	  (let recur ((tmpl (rule->template rule))
-		      (vars vars))
+	  (let subst1 ((tmpl (rule->template rule))
+		       (vars vars))
 	    (cond ((null? tmpl)
 		   tmpl)
 		  ((pair? tmpl)
@@ -269,62 +316,75 @@
 			   (if (pair? es)
 			       (if (= n (length (car es)))
 				   (check (cdr es))
-				   (error "syntax-rules: pattern variable length mismatch:"))))
+				   (length-error enames evals))))
 			 (append!
 			  (map (lambda (eval)
-				 (recur etmpl
-					(append!
-					 (map cons enames eval)
-					 vars)))
+				 (subst1 etmpl
+					 (append!
+					  (map cons enames eval)
+					  vars)))
 			       (apply map list evals))
-			  (recur (cdr tmpl) vars)))
-		       (cons (recur (car tmpl) vars)
-			     (recur (cdr tmpl) vars))))
+			  (subst1 (cdr tmpl) vars)))
+		       (cons (subst1 (car tmpl) vars)
+			     (subst1 (cdr tmpl) vars))))
 		  ((identifier? tmpl)
 		   (let ((a (assq tmpl ins)))
 		     (if a (cdr a) tmpl)))
 		  ((pattern-variable? tmpl)
 		   (@copy-tree (cdr (assq tmpl vars))))
 		  ((vector? tmpl)
-		   (list->vector (recur (vector->list tmpl) vars)))
+		   (list->vector (subst1 (vector->list tmpl) vars)))
 		  (else
 		   tmpl)))))
 
       ;; MACRO:COMPILE-SYNTAX-RULES
       (lambda (x-def env-def)
-	(or (and (list? x-def)
-		 (< 2 (length x-def))
-		 (list? (cadr x-def)))
-	    (error "Malformed syntax-rules:" x-def))
-	(let ((literals (cadr x-def)))
-	  (for-each (lambda (x)
-		      (or (identifier? x)
-			  (error "Bad literals list:" x-def)))
-		    literals)
-	  (let ((rules (map (lambda (rule-expr)
-			      (or (and (list? rule-expr)
-				       (= 2 (length rule-expr))
-				       (pair? (car rule-expr)))
-				  (error "Bad rule:" rule-expr))
-			      (compile-pattern literals rule-expr env-def))
-			    (cddr x-def))))
+	(let ((x-def (remove-line-numbers! x-def)))
+	  (or (and (list? x-def)
+		   (< 2 (length x-def))
+		   (list? (cadr x-def)))
+	      (error "Malformed syntax-rules:" x-def))
+	  (let ((literals (cadr x-def)))
+	    (for-each (lambda (x)
+			(or (identifier? x)
+			    (error "Bad literals list:" x-def)))
+		      literals)
+	    (let ((rules (map (lambda (rule-expr)
+				(or (and (list? rule-expr)
+					 (= 2 (length rule-expr))
+					 (let ((pat (car rule-expr)))
+					   (or (pair? pat)
+					       (identifier? pat))))
+				    (error "Bad rule:" rule-expr))
+				(compile-pattern literals rule-expr env-def))
+			      (cddr x-def))))
 
-	    (lambda (x-use env-use)
-	      (let loop ((rules rules))
-		(cond ((null? rules)
-		       (error "macro use does not match definition:"
-			      x-use))
-		      ((match (car rules) x-use env-use)
-		       => (lambda (vars)
-			    (substitute-in-template (car rules) vars env-def)))
-		      (else
-		       (loop (cdr rules))))))))))))
+	      (lambda (x-use env-use)
+		;;FIXME We should use the line numbers.
+		(let ((x-use (remove-line-numbers! x-use)))
+		  (let loop ((rules rules))
+		    (cond ((null? rules)
+			   (error "macro use does not match definition:"
+				  x-use))
+			  ((match (car rules) x-use env-use)
+			   => (lambda (vars)
+				(substitute-in-template
+				 x-use (car rules) vars env-def)))
+			  (else
+			   (loop (cdr rules))))))))))))))
 
-(define syntax-rules
+(define-syntax syntax-rules
   (procedure->syntax
    (lambda (expr env-def)
-     (procedure->memoizing-macro
-      (macro:compile-syntax-rules expr env-def)))))
+     (let ((transformer (macro:compile-syntax-rules expr env-def)))
+       (let loop ((rules (cddr expr)))
+	 (cond ((null? rules)
+		(procedure->memoizing-macro transformer))
+	       ((identifier? (caar rules))
+		(procedure->identifier-macro transformer))
+	       (else
+		(loop (cdr rules)))))))))
+
 
 ;; Explicit renaming macro facility, as in
 ;; W. Clinger, "Hygienic Macros Through Explicit Renaming"
@@ -358,22 +418,79 @@
      (lambda (exp env-def)
        `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def))))))
 
-(define define-syntax
-  (syntax-rules ()
-    ((define-syntax ?name ?val)
-     (define ?name (the-macro ?val)))))
-
-(define-syntax let-syntax
-  (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body)
-		    (@let-syntax
-			((?name (the-macro ?val)) ...) . ?body))))
-
-(define-syntax letrec-syntax
-  (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body)
-		    (@letrec-syntax
-		     ((?name (the-macro ?val)) ...) . ?body))))
-
-;; MACRO:EXPAND would require substantial work.
 (define macro:load load)
 (define macro:eval eval)
+(define (macro:expand . args)
+  (load (in-vicinity (implementation-vicinity) "Macexp"))
+  (apply macro:expand args))
 (provide 'macro)
+
+;; These are not part of the SYNTAX-RULES implementation, but I see
+;; no better place to put them:
+
+;; A debugging utility macro that is easy to grep for.
+(define-syntax @print
+  (syntax-rules (quote)
+    ((_ '?arg)
+     (begin (display '?arg)
+	    (newline)))
+    ((_ ?arg)
+     (begin (display '?arg)
+	    (display " => ")
+	    (let ((x ?arg))
+	      (write x)
+	      (newline)
+	      x)))
+    ((_ ?arg1 ?arg ...)
+     (begin
+       (@print ?arg1)
+       (begin
+	 (display " ")
+	 (@print ?arg))
+       ...))))
+
+(define-syntax @pprint
+  (syntax-rules (quote)
+    ((_ '?arg)
+     (begin (display '?arg)
+	    (newline)))
+    ((_ ?arg)
+     (begin (display '?arg)
+	    (display " => ")
+	    (let ((x ?arg))
+	      (pprint x)
+	      (newline)
+	      x)))
+    ((_ ?arg1 ?arg ...)
+     (begin
+       (@pprint ?arg1)
+       (begin
+	 (display " ")
+	 (@pprint ?arg))
+       ...))))
+
+;; Better run time error reporting than the version in Init*.scm,
+;; also only takes a given car or cdr once.
+(define-syntax destructuring-bind
+  (syntax-rules ()
+    ((_ "PARSE-LLIST" () ?val ?body ?err)
+     (if (null? ?val) ?body (?err '() ?val)))
+    ((_ "PARSE-LLIST" (?name1 . ?rest) ?val ?body ?err)
+     (if (pair? ?val)
+	 (let ((carv (car ?val))
+	       (cdrv (cdr ?val)))
+	   (destructuring-bind "PARSE-LLIST" ?name1 carv
+              (destructuring-bind "PARSE-LLIST" ?rest cdrv ?body ?err)
+	      ?err))
+	 (?err '(?name1 . ?rest) ?val)))
+    ((_ "PARSE-LLIST" ?name ?val ?body ?err)
+     (let ((?name ?val)) ?body))
+    ((_ ?llist ?val ?body1 ?body ...)
+     (let ((err (lambda (pat val)
+		  (slib:error 'destructuring-bind '?llist
+			      val "does not match" pat)))
+	   (val ?val))
+       (destructuring-bind "PARSE-LLIST" ?llist val
+			   ;;Use LET to allow internal DEFINE in body.
+			   (let () ?body1 ?body ...)
+			   err)))))
diff --git a/Macroexpand.scm b/Macroexpand.scm
deleted file mode 100644
index 3b658f8..0000000
--- a/Macroexpand.scm
+++ /dev/null
@@ -1,370 +0,0 @@
-;; Copyright (C) 1999 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, 59 Temple Place, Suite 330, Boston, MA 02111, 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.
-
-;;;; "Macroexpand.scm", macro expansion, respecting hygiene.
-;;; Author: Radey Shouman
-
-;; It is possible to break MACRO:EXPAND by redefining primitive
-;; syntax, eg LAMBDA, LET, QUOTE to different primitive syntax,
-;; or by defining any of  @LAMBDA, @LET, @LET*, @LETREC, @DO,
-;; or @EXPAND as primitive syntax.
-
-;; We still need LET-SYNTAX and LETREC-SYNTAX.
-
-(define macro:expand
-  (let (($lambda (renamed-identifier 'lambda '()))
-	($let (renamed-identifier 'let '()))
-	($let* (renamed-identifier 'let* '()))
-	($letrec (renamed-identifier 'letrec '()))
-	($do (renamed-identifier 'do '()))
-	($define (renamed-identifier 'define '()))
-	($quote (renamed-identifier 'quote '()))
-	($quasiquote (renamed-identifier 'quasiquote '()))
-	($unquote (renamed-identifier 'unquote '()))
-	($unquote-splicing (renamed-identifier 'unquote-splicing '()))
-	($case (renamed-identifier 'case '()))
-	($cond (renamed-identifier 'cond '()))
-	($begin (renamed-identifier 'begin '()))
-	($if (renamed-identifier 'if '()))
-	($and (renamed-identifier 'and '()))
-	($or (renamed-identifier 'or '()))
-	($set! (renamed-identifier 'set! '()))
-	($delay (renamed-identifier 'delay '()))
-	($syntax-quote (renamed-identifier 'syntax-quote '()))
-	($@apply (renamed-identifier '@apply '()))
-	($else (renamed-identifier 'else '()))
-	(@lambda (renamed-identifier '@lambda '()))
-	(@let (renamed-identifier '@let '()))
-	(@let* (renamed-identifier '@let* '()))
-	(@letrec (renamed-identifier '@letrec '()))
-	(@do (renamed-identifier '@do '()))
-	(@expand (renamed-identifier '@expand '())))
-
-    (define expander
-      (macro:compile-syntax-rules
-       '(syntax-rules (lambda let letrec let* do @let*)
-	  ((_ (lambda ?formals ?body ...))
-	   (@lambda ?formals ?body ...))
-
-	  ((_ (let ((?name ?val) ...) ?body ...))
-	   (@let ((?name ...) ?val ...) ?body ...))
-	  ((_ (let ?proc ((?name ?val) ...) ?body ...))
-	   (@expand
-	    (letrec ((?proc (lambda (?name ...) ?body ...)))
-	      (?proc ?val ...))))
-
-	  ((_ (letrec ((?name ?val) ...) ?body ...))
-	   (@letrec ((?name ...) ?val ...) ?body ...))
-
-	  ((_ (let* () ?body ...))
-	   (@let (()) ?body ...))
-	  ((_ (let* ((?name1 ?val1) (?name ?val) ...) ?body ...))
-	   (@expand
-	    (@let* (?name1 ?val1) (let* ((?name ?val) ...) ?body ...))))
-	  ((_ (@let* (?name ?val ...) (let* () ?body ...)))
-	   (@let* (?name ?val ...) ?body ...))
-	  ((_ (@let* (?name ?val ...)
-		(let* ((?name2 ?val2) (?name3 ?val3) ...) ?body ...)))
-	   (@expand
-	    (@let* (?name ?val ... ?name2 ?val2)
-	      (let* ((?name3 ?val3) ...) ?body ...))))
-	  ((_ (@let* (?name ?val ...) ?body ...))
-	   (@let* (?name ?val ...) ?body ...))
-
-	  ((_ (do ((?var ?init ?step) ...)
-		  (?test ?clause ...)
-		?body ...))
-	   (@do (?var ...) (?init ...)
-	     (?test ?clause ...)
-	     (?body ...)
-	     (?step ...)))
-
-	  ((_ ?form)
-	   ?form))
-       '()))
-
-    (define (simplify-identifiers expr env)
-      (let simplify ((expr expr))
-	(cond ((identifier? expr)
-	       (let ((sym (identifier->symbol expr)))
-		 (if (identifier-equal? sym expr env) sym expr)))
-	      ((pair? expr)
-	       (cons (simplify (car expr))
-		     (simplify (cdr expr))))
-	      (else expr))))
-
-    (define (unpaint expr)
-      (cond ((identifier? expr)
-	     (identifier->symbol expr))
-	    ((pair? expr)
-	     (cons (unpaint (car expr)) (unpaint (cdr expr))))
-	    ((vector? expr)
-	     (list->vector (map unpaint (vector->list expr))))
-	    (else expr)))
-
-    (define (defines->bindings defs)
-      (reverse				;purely cosmetic
-       (map (lambda (b)
-	      (if (pair? (cadr b))
-		  (list (caadr b)
-			(cons $lambda (cons (cdadr b) (cddr b))))
-		  (cdr b)))
-	    defs)))
-
-    (define (expand-define expr env)
-      (let ((binding (car (defines->bindings (list expr)))))
-	(cons (simplify-identifiers $define env)
-	      (list (simplify-identifiers (car binding) env)
-		    (macro:expand (cadr binding) env)))))
-
-    (define (expand-body expr-list env)
-      (let loop ((defines '())
-		 (exprs expr-list))
-	(if (null? exprs) #f	; should check higher up.
-	    (let ((exp1 (macro:expand (car exprs) env)))
-	      (if (and (pair? exp1)
-		       (identifier? (car exp1))
-		       (identifier-equal? (car exp1) $define env))
-		  (loop (cons exp1 defines) (cdr exprs))
-		  (if (null? defines)
-		      (cons exp1 (expand* (cdr exprs) env))
-		      (let ((bindings (defines->bindings defines)))
-			(list
-			 (macro:expand
-			  (cons $letrec (cons bindings exprs))
-			  env)))))))))
-
-    (define (expand* exprs env)
-      (map (lambda (x)
-	     (macro:expand x env))
-	   exprs))
-
-    ;;(@lambda formals body ...)
-    (define (expand-lambda expr env)
-      (let* ((formals (cadr expr))
-	     (body (cddr expr))
-	     (bound
-	      (let recur ((f formals))
-		(cond ((null? f) '())
-		      ((pair? f) (cons 'required (recur (cdr f))))
-		      ((identifier? f) (list 'rest-list))
-		      (else (error 'lambda 'bad-formals expr)))))
-	     (env1 (extended-environment formals bound env)))
-	(cons (simplify-identifiers $lambda env)
-	      (cons (simplify-identifiers formals env1)
-		    (expand-body body env1)))))
-
-    ;;(@let ((formals) bindings) body ...)
-    (define (expand-let expr env)
-      (let* ((formals (caadr expr))
-	     (bindings (expand* (cdadr expr) env))
-	     (env1 (extended-environment formals
-					       (map (lambda (x) 'let) formals)
-					       env)))
-	(cons (simplify-identifiers $let env)
-	      (cons (map list formals bindings)
-		    (expand-body (cddr expr) env1)))))
-
-    (define (expand-let* expr env)
-      (let loop ((inp (cadr expr))
-		 (formals '())
-		 (bindings '())
-		 (env1 env))
-	(if (null? inp)
-	    (cons (simplify-identifiers $let* env)
-		  (map list (reverse formals) (reverse bindings))
-		  (expand-body (cddr expr) env1))
-	    (loop (cddr inp)
-		  (cons (car inp) formals)
-		  (cons (macro:expand (cadr inp) env1) bindings)
-		  (extended-environment (car inp) 'let* env1)))))
-
-    ;;(@letrec ((formals) bindings) body ...)
-    (define (expand-letrec expr env)
-      (let* ((formals (caadr expr))
-	     (env1 (extended-environment
-		   formals
-		   (map (lambda (x) 'letrec) formals)
-		   env))
-	     (bindings (expand* (cdadr expr) env1)))
-	(cons (simplify-identifiers $letrec env)
-	      (cons (map list formals bindings)
-		    (expand-body (cddr expr) env1)))))
-
-    ;;(@do vars inits (test clause ...) (body ...) steps)
-    (define (expand-do expr env)
-      (let* ((vars (cadr expr))
-	     (inits (expand* (caddr expr) env))
-	     (env1 (extended-environment
-		   vars (map (lambda (x) 'do) inits) env))
-	     (steps (expand* (list-ref expr 5) env1)))
-	(cons (simplify-identifiers $do env)
-	      (cons
-	       (map list vars inits steps)
-	       (cons (expand* (cadddr expr) env1)
-		     (expand* (list-ref expr 4) env1))))))
-
-    (define (expand-quote expr env)
-      (let ((obj (cadr expr)))
-	(if (or (boolean? obj)
-		(number? obj)
-		(string? obj))
-	    obj
-	    (list (simplify-identifiers $quote env)
-		  (unpaint obj)))))
-
-    (define (expand-quasiquote expr env)
-      (list (simplify-identifiers $quasiquote env)
-	    (let qq ((expr (cadr expr))
-		     (level 0))
-	      (cond ((vector? expr)
-		     (list->vector (qq (vector->list expr) level)))
-		    ((not (pair? expr))
-		     (unpaint expr))
-		    ((not (identifier? (car expr)))
-		     (cons (qq (car expr) level) (qq (cdr expr) level)))
-		    ((identifier-equal? (car expr) $quasiquote env)
-		     (list (simplify-identifiers $quasiquote env)
-			   (qq (cadr expr) (+ level 1))))
-		    ((or (identifier-equal? (car expr) $unquote env)
-			 (identifier-equal? (car expr) $unquote-splicing env))
-		     (list (simplify-identifiers (car expr) env)
-			   (if (zero? level)
-			       (macro:expand (cadr expr) env)
-			       (qq (cadr expr) (- level 1)))))
-		    (else
-		     (cons (qq (car expr) level)
-			   (qq (cdr expr) level)))))))
-
-    (define (expand-case expr env)
-      (cons (simplify-identifiers $case env)
-	    (cons (macro:expand (cadr expr) env)
-		  (map (lambda (clause)
-			 (cond ((pair? (car clause))
-				(cons (unpaint (car clause))
-				      (expand* (cdr clause) env)))
-			       ((and (identifier? (car clause))
-				     (identifier-equal? $else
-							(car clause) env))
-				(cons (simplify-identifiers
-				       (car clause) env)
-				      (expand* (cdr clause) env)))
-			       (else (error 'macro:expand 'case
-					    "bad clause" expr))))
-		       (cddr expr)))))
-
-    (define (expand-cond expr env)
-      (cons (simplify-identifiers $cond env)
-	    (map (lambda (clause) (expand* clause env))
-		 (cdr expr))))
-
-    ;; for IF, BEGIN, SET!
-    (define (expand-simple expr env)
-      (cons (simplify-identifiers (car expr) env)
-	    (expand* (cdr expr) env)))
-
-    (define (expand-primitives expr env)
-      (let loop ((expr (list '@expand expr)))
-	(let* ((expanded (expander expr env))
-	       (head (car expanded)))
-	  (cond ((identifier-equal? @LAMBDA head env)
-		 (expand-lambda expanded env))
-		((identifier-equal? @LET head env)
-		 (expand-let expanded env))
-		((identifier-equal? @LET* head env)
-		 (expand-let* expanded env))
-		((identifier-equal? @LETREC head env)
-		 (expand-letrec expanded env))
-		((identifier-equal? @DO head env)
-		 (expand-do expanded env))
-		((identifier-equal? $QUOTE head env)
-		 (expand-quote expanded env))
-		((identifier-equal? $QUASIQUOTE head env)
-		 (expand-quasiquote expanded env))
-		((identifier-equal? $BEGIN head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $IF head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $AND head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $OR head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $SET! head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $DELAY head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $@APPLY head env)
-		 (expand-simple expanded env))
-		((identifier-equal? $CASE head env)
-		 (expand-case expanded env))
-		((identifier-equal? $COND head env)
-		 (expand-cond expanded env))
-		((and (identifier-equal? $DEFINE head env)
-		      (null? (environment->tree env)))
-		 (expand-define expanded env))
-		((identifier-equal? $SYNTAX-QUOTE head env)
-		 (cons (simplify-identifiers head env)
-		       (cdr expanded)))
-		((identifier-equal? @EXPAND head env)
-		 (loop expanded))
-		(else
-		 (print 'macro:expand
-			"Warning: unknown primitive syntax" (car expanded))
-		 expanded)))))
-
-    (lambda (expr env)
-      (let loop ((expr expr))
-	(let ((expanded (@macroexpand1 expr env)))
-	  (cond ((not expanded)
-		 (cond ((pair? expr)
-			(if (list? expr)
-			    (expand* expr env)
-			    (print 'macro:expand "expansion not a list" expr)))
-		       ((identifier? expr)
-			(simplify-identifiers expr env))
-		       (else expr)))
-		((eq? expanded expr)
-		 (expand-primitives expr env))
-		(else
-		 (loop expanded))))))))
-
-;;; Local Variables:
-;;; eval: (put 'identifier-case 'scheme-indent-function 1)
-;;; End:
diff --git a/Makefile b/Makefile
index 8a92daa..57f6594 100644
--- a/Makefile
+++ b/Makefile
@@ -15,26 +15,26 @@
 # the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 #
 # As a special exception, the Free Software Foundation gives permission
-# for additional uses of the text contained in its release of GUILE.
+# for additional uses of the text contained in its release of SCM.
 #
-# The exception is that, if you link the GUILE library with other files
+# The exception is that, if you link the SCM 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.
+# linking the SCM 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
+# Free Software Foundation under the name SCM.  If you copy
 # code from other Free Software Foundation releases into a copy of
-# GUILE, as the General Public License permits, the exception does
+# SCM, 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
+# If you write modifications of your own for SCM, it is your choice
 # whether to permit this exception to apply to your modifications.
 # If you do not wish that, delete this exception notice.
 
@@ -42,17 +42,39 @@
 # Author: Aubrey Jaffer
 
 SHELL = /bin/sh
-CPROTO = cproto
-#CC =
+#CC = gcc
 CFLAGS = -g
 #LIBS =
 LD = $(CC) -g
+SCMLIT = ./scmlit
+SCMEXE = ./scm
+
+#BUILD = ./build -hsystem -p svr4-gcc-sun-ld
+BUILD = ./build -hsystem
+
+#for RPMs
+RELEASE = 1
+
+intro:
+	@echo
+	@echo "This is the scm$(VERSION) distribution.  Read \"scm.info\""
+	@echo "to learn how to build and install SCM.  Or browse"
+	@echo "      http://swissnet.ai.mit.edu/~jaffer/SCM.html"
+	@echo
+	$(MAKE) scm
+
+#srcdir=$(HOME)/scm/
+#srcdir=/usr/local/src/scm/
+include srcdir.mk
+srcdir.mk:	Makefile
+	echo "CPROTO=`type cproto | sed 's%.* %%'`" > srcdir.mk
+	echo "srcdir=`pwd`/" >> srcdir.mk
 
 # directory where COPYING and InitXXX.scm reside.
 #IMPLPATH = /usr/local/src/scm/
 #this one is good for bootstrapping
-IMPLPATH = `pwd`/
-# Pathname where InitXXX.scm resides.
+#IMPLPATH = `pwd`/
+IMPLPATH=$(srcdir)
 include patchlvl.h
 IMPLINIT = $(IMPLPATH)Init$(VERSION).scm
 
@@ -60,30 +82,27 @@ IMPLINIT = $(IMPLPATH)Init$(VERSION).scm
 # SCM_INIT_PATH is the environment variable whose value is the
 # pathname where InitXXX.scm resides.
 
-intro:
-	@echo
-	@echo "This is the scm$(VERSION) distribution.  Read \"scm.info\""
-	@echo "to learn how to build and install SCM.  Or browse"
-	@echo "      http://swissnet.ai.mit.edu/~jaffer/SCM.html"
-
 cfiles = scmmain.c 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 script.c
+	findexec.c script.c debug.c
 ofiles = scm.o time.o repl.o scl.o sys.o eval.o subr.o unif.o rope.o \
-	continue.o findexec.o script.o
+	continue.o findexec.o script.o debug.o
 # ramap.o
-ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macroexpand.scm \
-	Tscript.scm
-xfiles = x.c x.h xgen.scm xevent.scm xevent.h inc2scm x11.scm
+ifiles = Init$(VERSION).scm Transcen.scm Link.scm Macro.scm Macexp.scm \
+	Tscript.scm compile.scm
+hobfiles = hobbit.scm scmhob.scm scmhob.h
+xafiles = xatoms.scm x11.scm xevent.scm keysymdef.scm
+xfiles = x.c x.h xgen.scm xevent.h inc2scm $(xafiles)
 
 all:	require.scm
 	$(MAKE) mydlls
-	$(MAKE) myscm
+	$(MAKE) myscm5
+	$(MAKE) x.so
 require.scm:
 	cp -p requires.scm require.scm
 
-scmlit:	$(ofiles) scmmain.o require.scm
+scmlit:	$(ofiles) scmmain.o require.scm Makefile
 	$(LD) -o scmlit $(ofiles) scmmain.o $(LIBS)
 	$(MAKE) checklit
 scmflags.h:	scmflags
@@ -91,6 +110,7 @@ scmflags:
 	echo "#ifndef IMPLINIT" > newflags.h
 	echo "#define IMPLINIT \"$(IMPLINIT)\"" >> newflags.h
 	echo "#endif" >> newflags.h
+	echo "/*#define CAUTIOUS*/" >> newflags.h
 	-if (diff newflags.h scmflags.h) then rm newflags.h; \
 		 else mv newflags.h scmflags.h; fi
 
@@ -100,6 +120,7 @@ scm.o:	scm.c scm.h scmfig.h scmflags.h patchlvl.h
 scmmain.o:	scmmain.c scm.h scmfig.h scmflags.h patchlvl.h
 scl.o:	scl.c scm.h scmfig.h scmflags.h
 eval.o:	eval.c scm.h scmfig.h scmflags.h setjump.h
+debug.o: debug.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
@@ -109,17 +130,16 @@ 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 scmflags.h
 
-srcdir=$(HOME)/scm/
-
 udscm4:	$(cfiles) $(hfiles) build.scm build
-	$(srcdir)build -hsystem -o udscm4 -s $(IMPLPATH) -Fcautious \
-	bignums arrays inexact engineering-notation dump dynamic-linking
+	$(BUILD) -o udscm4 -s $(IMPLPATH) \
+	 -Fcautious bignums arrays inexact dump dynamic-linking \
+	 engineering-notation
 	rm $(ofiles) scmmain.o
 
-udscm5:	$(cfiles) $(hfiles) build.scm build
-	$(srcdir)build -hsystem -o udscm5 -l debug -s $(IMPLPATH) -Fcautious \
-	bignums arrays inexact engineering-notation dump dynamic-linking \
-	macro #-DNO_SYM_GC
+udscm5:	$(cfiles) $(hfiles) build.scm build Makefile
+	$(BUILD) -o udscm5 -s $(IMPLPATH) \
+	 -Fcautious bignums arrays inexact dump dynamic-linking \
+	 macro engineering-notation #-DNO_SYM_GC
 	rm $(ofiles) scmmain.o
 
 myscm4:	udscm4 $(ifiles) require.scm
@@ -127,87 +147,104 @@ myscm4:	udscm4 $(ifiles) require.scm
 	-mv scm scm~
 	echo "(quit)" | ./udscm4 -no-init-file -o scm
 
-myscm:	udscm5 $(ifiles) require.scm
+myscm5:	udscm5 $(ifiles) require.scm
 	-rm slibcat implcat
 	-mv scm scm~
 	echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm
 	$(MAKE) check
+	$(MAKE) checkmacro
+
+scm:	scmlit
+	$(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays
+	$(MAKE) check
 
 mylib:	libscm.a
 libscm.a:
-	$(srcdir)build -hsystem -Fcautious bignums arrays inexact \
+	$(BUILD) -Fcautious bignums arrays inexact \
 	dynamic-linking -t lib
 libtest:	libscm.a libtest.c
 	gcc -o libtest libtest.c libscm.a -ldl -lm -lc
 	./libtest
 pgscm:
-	$(srcdir)build -hsystem -s $(IMPLPATH) -Fcautious bignums arrays \
+	$(BUILD) -s $(IMPLPATH) -Fcautious bignums arrays \
 	inexact engineering-notation dump dynamic-linking -o udscm \
 	 --compiler-options=-pg --linker-options=-pg -DLACK_SETITIMER
 	echo "(quit)" | ./udscm -no-init-file -o pgscm
 mydebug:
-	$(srcdir)build -hsystem -oudgdbscm -s $(IMPLPATH) -F cautious \
-	 bignums arrays inexact engineering-notation dump dynamic-linking \
-	 macro \
-	 debug --compiler-options=-Wall --linker-options=-Wall #-DTEST_FARLOC
+	$(BUILD) -oudgdbscm -s $(IMPLPATH) \
+	 -F cautious bignums arrays inexact engineering-notation dump \
+	 dynamic-linking macro debug \
+	 --compiler-options=-Wall --linker-options=-Wall \
+	 -DNO_ENV_CACHE	 #-DTEST_FARLOC -DTEST_SCM2PTR
 	echo "(quit)" | ./udgdbscm -no-init-file -r5 -o gdbscm
 
 incdir=/usr/include/
-x11.scm:	inc2scm Makefile
+x11.scm:	inc2scm
 	rm -f x11.scm
-	./inc2scm x11.scm x: $(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h X11/Xutil.h
-xevent.h:	xgen.scm
-	./xgen.scm $(incdir)X11/Xlib.h
+	$(SCMLIT) -l inc2scm x11.scm x: $(incdir) X11/X.h X11/cursorfont.h X11/Xlib.h \
+	 X11/Xutil.h
+keysymdef.scm:	inc2scm
+	rm -f keysymdef.scm
+	$(SCMLIT) -l inc2scm keysymdef.scm x: $(incdir) X11/keysym.h X11/keysymdef.h
+xevent.h xevent.scm xatoms.scm:	xgen.scm Makefile
+	$(SCMLIT) -l xgen.scm $(incdir)X11/Xlib.h
 x.h:	x.c xevent.h
-	$(CPROTO) x.c > x.h
+	if [ ! -z "$(CPROTO)" ]; then $(CPROTO) x.c > x.h; fi
 x.so:	x.c x.h xevent.h
-	$(srcdir)build -h system -Fx -t dll --compiler-options=-Wall
-mydlls:	x.so
+	$(BUILD) -Fx -t dll --compiler-options=-Wall
+mydlls:
 	if [ -f /usr/lib/libreadline.so ]; \
-		then $(srcdir)build -h system -Fedit-line -t dll;fi
-	$(srcdir)build -h system -Fcurses -t dll
-	$(srcdir)build -h system -t dll -c sc2.c rgx.c record.c gsubr.c \
+		then $(BUILD) -Fedit-line -t dll; fi
+	$(BUILD) -Fcurses -t dll
+	$(BUILD) -t dll -c sc2.c rgx.c record.c gsubr.c \
 		ioext.c posix.c unix.c socket.c ramap.c
 myturtle:
-	$(srcdir)build -h system -F turtlegr -t dll
+	$(BUILD) -Fturtlegr -t dll
 
 implcat:	*.so mkimpcat.scm
-	./scmlit -lmkimpcat.scm
+	$(SCMLIT) -lmkimpcat.scm
 
 checklit:
-	./scmlit -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
+	$(SCMLIT) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \
+	-e '(or (null? errs) (quit 1))'
 check:	r4rstest.scm
-	./scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)'
+	$(SCMEXE) -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)' \
+	-e '(or (null? errs) (quit 1))'
+checkmacro: syntest1.scm syntest2.scm r4rstest.scm
+	$(SCMEXE) -rmacro -fsyntest1.scm -fsyntest2.scm \
+	 -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)' -fsyntest1 \
+	-e '(or (null? errs) (quit 1))'
 bench:
 	echo `whoami`@`hostname` testing scm \
-	 `scm -e'(display *scm-version*)'` >> BenchLog
+	 `$(SCMEXE) -e'(display *scm-version*)'` >> BenchLog
 	echo  on `date` >> BenchLog
 	ls -l scm >> BenchLog
 	size scm >> BenchLog
 	uname -a >> BenchLog
-	./scm -lbench.scm
+	$(SCMEXE) -lbench.scm
 	cat bench.log >> BenchLog
 	echo >> BenchLog
 	echo
 	tail -20 BenchLog
 benchlit:
 	echo `whoami`@`hostname` testing scmlit \
-	 `scmlit -e'(display *scm-version*)'` >> BenchLog
+	 `$(SCMLIT) -e'(display *scm-version*)'` >> BenchLog
 	echo  on `date` >> BenchLog
 	ls -l scmlit >> BenchLog
 	size scmlit >> BenchLog
 	uname -a >> BenchLog
-	./scmlit -lbench.scm
+	$(SCMLIT) -lbench.scm
 	cat bench.log >> BenchLog
 	echo >> BenchLog
 	echo
 	tail -20 BenchLog
 report:
-	scmlit -e"(slib:report #t)"
-	scm -e"(slib:report #t)"
+	$(SCMLIT) -e"(slib:report #t)"
+	$(SCMEXE) -e"(slib:report #t)"
 
+htmldir=../public_html/
 dvidir=../dvi/
-dvi:	$(dvidir)scm.dvi $(dvidir)Xlibscm.dvi
+dvi:	$(dvidir)scm.dvi $(dvidir)Xlibscm.dvi $(dvidir)hobbit.dvi
 $(dvidir)scm.dvi:	version.txi scm.texi platform.txi features.txi\
 	$(dvidir)scm.fn Makefile
 #	cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)scm.texi
@@ -215,36 +252,77 @@ $(dvidir)scm.dvi:	version.txi scm.texi platform.txi features.txi\
 	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi
 $(dvidir)scm.fn:
 	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)scm.texi
-$(dvidir)Xlibscm.dvi:	version.txi Xlibscm.texi \
-	$(dvidir)Xlibscm.fn Makefile
+$(dvidir)Xlibscm.dvi:	version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile
 #	cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)Xlibscm.texi
 	-(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex Xlibscm.??)
 	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi
 $(dvidir)Xlibscm.fn:
 	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)Xlibscm.texi
+$(dvidir)hobbit.dvi:	version.txi hobbit.texi $(dvidir)hobbit.fn Makefile
+#	cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)hobbit.texi
+	-(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex hobbit.??)
+	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi
+$(dvidir)hobbit.fn:
+	cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)hobbit.texi
 xdvi:	$(dvidir)scm.dvi
 	xdvi -s 6 $(dvidir)scm.dvi
 Xdvi:	$(dvidir)Xlibscm.dvi
 	xdvi -s 6 $(dvidir)Xlibscm.dvi
-
-htmldir=../public_html/
-html:	$(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html
+hobdvi:	$(dvidir)hobbit.dvi
+	xdvi -s 6 $(dvidir)hobbit.dvi
+
+pdf:	$(htmldir)scm.pdf $(htmldir)Xlibscm.pdf $(htmldir)hobbit.pdf
+$(htmldir)scm.pdf:	version.txi scm.texi platform.txi features.txi\
+			$(dvidir)scm.fn Makefile
+	cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)scm.texi
+	mv $(dvidir)scm.pdf $(htmldir)
+$(htmldir)Xlibscm.pdf:	version.txi Xlibscm.texi $(dvidir)Xlibscm.fn Makefile
+	cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)Xlibscm.texi
+	mv $(dvidir)Xlibscm.pdf $(htmldir)
+$(htmldir)hobbit.pdf:	version.txi hobbit.texi $(dvidir)hobbit.fn Makefile
+	cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)hobbit.texi
+	mv $(dvidir)hobbit.pdf $(htmldir)
+xpdf:	$(htmldir)scm.pdf
+	xpdf -z 3 $(htmldir)scm.pdf
+Xpdf:	$(htmldir)Xlibscm.pdf
+	xpdf -z 3 $(htmldir)Xlibscm.pdf
+hobpdf:	$(htmldir)hobbit.pdf
+	xpdf -z 3 $(htmldir)hobbit.pdf
+
+PREVDOCS = prevdocs/
+html:	$(htmldir)scm_toc.html $(htmldir)Xlibscm_toc.html $(htmldir)hobbit_toc.html
 
 scm_toc.html:	version.txi scm.texi platform.txi features.txi
 	texi2html -split -verbose scm.texi
-Xlibscm_toc.html:	$(htmldir)Xlibscm_toc.html
-$(htmldir)Xlibscm_toc.html:	version.txi Xlibscm.texi
-	cd $(htmldir);texi2html -split -verbose $(srcdir)Xlibscm.texi
-
-scmprev/scm_toc.html:
-#	cd scmprev;make scm_toc.html
-	cd scmprev;texi2html -split -verbose scm.texi
-
-$(htmldir)scm_toc.html:	scmprev/scm_toc.html scm_toc.html Makefile
-	hitch scmprev/scm_\*.html scm_\*.html $(htmldir)
+Xlibscm_toc.html:	version.txi Xlibscm.texi
+	texi2html -split -verbose Xlibscm.texi
+hobbit_toc.html:	version.txi hobbit.texi
+	texi2html -split -verbose hobbit.texi
+
+$(htmldir)scm_toc.html:	scm_toc.html Makefile
+	-rm -f scm_stoc.html
+	if [ -f $(PREVDOCS)scm_toc.html ]; \
+		then hitch $(PREVDOCS)scm_\*.html scm_\*.html $(htmldir); \
+		else cp scm_*.html $(htmldir); fi
+$(htmldir)Xlibscm_toc.html:	Xlibscm_toc.html Makefile
+	-rm -f Xlibscm_stoc.html
+	cp Xlibscm_*.html $(htmldir)
+$(htmldir)hobbit_toc.html:	hobbit_toc.html Makefile
+	-rm -f hobbit_stoc.html
+	cp hobbit_*.html $(htmldir)
+
+$(PREVDOCS)scm_toc.html:
+$(PREVDOCS)scm.info:	srcdir.mk Makefile
+	cd $(PREVDOCS); unzip -a $(dest)scm*.zip
+	rm $(PREVDOCS)scm/scm.info
+	cd $(PREVDOCS)scm; make scm.info; make scm_toc.html
+	cd $(PREVDOCS); mv -f scm/scm.info scm/*.html ./
+	rm -rf $(PREVDOCS)scm
 
 ################ INSTALL DEFINITIONS ################
 
+rpm_prefix=/usr/src/redhat/
+
 prefix = /usr/local/
 exec_prefix = $(prefix)
 # directory where `make install' will put executable.
@@ -258,23 +336,22 @@ infodir = $(prefix)info/
 includedir = $(prefix)include/
 
 README:	build build.scm scm.info
-	scm -l build -e"(make-readme)"
+	$(SCMEXE) -l build -e"(make-readme)"
 
 info:	installinfo
-installinfo:	$(infodir)scm.info $(infodir)Xlibscm.info
+installinfo:	$(infodir)scm.info $(infodir)Xlibscm.info $(infodir)hobbit.info
 
 platform.txi:	build.scm
-	scmlit -r database-browse -l build.scm -e "(browse build 'platform)" \
+	$(SCMLIT) -r database-browse -l build.scm -e "(browse build 'platform)" \
 	> platform.txi
 features.txi:	build build.scm
-	scmlit -l build -e"(make-features-txi)"
-scm$(VERSION).info:	version.txi scm.texi platform.txi features.txi
-	-mv scm.info scmtemp.info
+	$(SCMLIT) -l build -e"(make-features-txi)"
+scm.info:	version.txi scm.texi platform.txi features.txi
 	makeinfo scm.texi --no-split -o scm.info
 	mv scm.info scm$(VERSION).info
-	-mv scmtemp.info scm.info
-scm.info:	scm$(VERSION).info
-	infobar scmprev/scm.info scm$(VERSION).info scm.info
+	if [ -f $(PREVDOCS)scm.info ]; \
+		then infobar $(PREVDOCS)scm.info scm$(VERSION).info scm.info; \
+		else cp scm$(VERSION).info scm.info; fi
 $(infodir)scm.info:	scm.info
 	cp -p scm.info $(infodir)scm.info
 	-install-info $(infodir)scm.info $(infodir)dir
@@ -282,45 +359,52 @@ $(infodir)scm.info:	scm.info
 
 Xlibscm.info:	version.txi Xlibscm.texi
 	makeinfo Xlibscm.texi --no-split -o Xlibscm.info
-$(infodir)Xlibscm.info:	
+$(infodir)Xlibscm.info:	Xlibscm.info
 	cp Xlibscm.info $(infodir)Xlibscm.info
 	-install-info $(infodir)Xlibscm.info $(infodir)/dir
 	-rm $(infodir)Xlibscm.info*.gz
 
+hobbit.info:	version.txi hobbit.texi
+	makeinfo hobbit.texi --no-split -o hobbit.info
+$(infodir)hobbit.info:	hobbit.info
+	cp hobbit.info $(infodir)hobbit.info
+	-install-info $(infodir)hobbit.info $(infodir)/dir
+	-rm $(infodir)hobbit.info*.gz
+
 infoz:	installinfoz
-installinfoz:	$(infodir)scm.info.gz $(infodir)Xlibscm.info.gz
+installinfoz:	$(infodir)scm.info.gz $(infodir)Xlibscm.info.gz $(infodir)hobbit.info.gz
 $(infodir)scm.info.gz:	$(infodir)scm.info
 	gzip -f $(infodir)scm.info
 $(infodir)Xlibscm.info.gz:	$(infodir)Xlibscm.info
 	gzip -f $(infodir)Xlibscm.info
+$(infodir)hobbit.info.gz:	$(infodir)hobbit.info
+	gzip -f $(infodir)hobbit.info
 
 install:	scm.1
 	test -d $(bindir) || mkdir $(bindir)
 	test -d $(mandir) || mkdir $(mandir)
 	test -d $(man1dir) || mkdir $(man1dir)
-	-cp scm $(bindir)
-#	-strip $(bindir)scm
+	-cp scm scmlit $(bindir)
+	-strip $(bindir)scmlit
 	-cp scm.1 $(man1dir)
 	test -d $(libdir) || mkdir $(libdir)
 	test -d $(libscmdir) || mkdir $(libscmdir)
-	-cp Init$(VERSION).scm Link.scm Transcen.scm Macro.scm Tscript.scm \
-		COPYING $(libscmdir)
+	-cp $(ifiles) $(hobfiles) COPYING r4rstest.scm $(libscmdir)
 	test -f $(libscmdir)require.scm || \
 		cp requires.scm $(libscmdir)require.scm
-	-cp mkimpcat.scm Iedline.scm *.sl *.so $(libscmdir)
+	-cp build build.scm mkimpcat.scm Iedline.scm *.sl *.so $(xafiles)\
+		$(libscmdir)
 
 installlib:
 	test -d $(includedir) || mkdir $(includedir)
-	cp scm.h $(includedir)scm.h
-	cp scmfig.h $(includedir)scmfig.h
+	cp scm.h scmfig.h scmflags.h $(includedir)
 	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 $(includedir)scm.h $(includedir)scmfig.h $(includedir)scmflags.h
 	-rm $(libdir)libscm.a
 #	-rm $(libscmdir)Init$(VERSION).scm
 #	-rm $(libscmdir)Link.scm
@@ -350,18 +434,20 @@ 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
-tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm
+tfiles = r4rstest.scm example.scm pi.scm pi.c split.scm bench.scm \
+	syntest2.scm syntest1.scm
 dfiles = ANNOUNCE README COPYING scm.1 scm.doc QUICKREF \
-	scm.info scm.texi Xlibscm.info Xlibscm.texi ChangeLog
+	scm.info scm.texi Xlibscm.info Xlibscm.texi hobbit.info hobbit.texi \
+	ChangeLog
 mfiles = Makefile build.scm build build.bat requires.scm \
-	.gdbinit mkimpcat.scm disarm.scm
+	.gdbinit mkimpcat.scm disarm.scm scm.spec
 vfiles = setjump.mar setjump.s
 afiles = $(dfiles) $(cfiles) $(hfiles) $(ifiles) $(tfiles) $(mfiles) \
-	$(vfiles) $(ufiles) $(xfiles)
+	$(hobfiles) $(vfiles) $(ufiles) $(xfiles)
 
 makedev = make -f $(HOME)/makefile.dev
 CHPAT=$(HOME)/bin/chpat
-RSYNC=rsync -v --rsync-path bin/rsync
+RSYNC=rsync -avessh
 dest = $(HOME)/dist/
 temp/scm:	$(afiles)
 	-$(RM_R) temp
@@ -369,10 +455,13 @@ temp/scm:	$(afiles)
 	mkdir temp/scm
 	ln $(afiles) temp/scm
 
-release:	dist
-	cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE
-	$(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE nestle.ai.mit.edu:public_html/
-	$(RSYNC) $(dest)README $(dest)scm$(VERSION).zip nestle.ai.mit.edu:dist/
+release:	dist rpm
+	cvs tag -F scm$(VERSION)
+	cp $(srcdir)ANNOUNCE $(htmldir)SCM_ANNOUNCE.txt
+	$(RSYNC) $(htmldir)SCM.html $(htmldir)SCM_ANNOUNCE.txt nestle.ai.mit.edu:public_html/
+	$(RSYNC) $(dest)README $(dest)scm$(VERSION).zip \
+	 $(dest)scm-$(VERSION)-$(RELEASE).src.rpm $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm \
+	 nestle.ai.mit.edu:dist/
 #	upload $(dest)README $(dest)scm$(VERSION).zip ftp.gnu.org:gnu/jacal/
 #	$(MAKE) indiana
 indiana:
@@ -385,7 +474,7 @@ indiana:
 postnews:
 	echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \
 	inews -h -O -S \
-	-f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \
+	-f "announce@voluntocracy.org (Aubrey Jaffer & Radey Shouman)" \
 	 -t "SCM$(VERSION) Released" -d world
 
 upzip:	$(HOME)/pub/scm.zip
@@ -394,7 +483,15 @@ upzip:	$(HOME)/pub/scm.zip
 dist:	$(dest)scm$(VERSION).zip
 $(dest)scm$(VERSION).zip:	temp/scm
 	$(makedev) DEST=$(dest) PROD=scm ver=$(VERSION) zip
-	cvs tag -F scm$(VERSION)
+
+rpm:	pubzip
+# $(dest)scm-$(VERSION)-$(RELEASE).i386.rpm:	$(dest)scm$(VERSION).zip
+	cp -f $(HOME)/pub/scm.zip $(rpm_prefix)SOURCES/scm$(VERSION).zip
+	rpm -ba scm.spec	# --clean
+	rm $(rpm_prefix)SOURCES/scm$(VERSION).zip
+	mv $(rpm_prefix)RPMS/i386/scm-$(VERSION)-$(RELEASE).i386.rpm \
+	   $(rpm_prefix)SRPMS/scm-$(VERSION)-$(RELEASE).src.rpm $(dest)
+
 shar:	scm.shar
 scm.shar:	temp/scm
 	$(makedev) PROD=scm shar
@@ -410,7 +507,7 @@ doszip:	/c/scm/dist/scm$(VERSION).zip
 	$(makedev) DEST=/c/scm/dist/ PROD=scm ver=$(VERSION) zip
 	cd ..; zip -9ur /c/scm/dist/scm$(VERSION).zip \
 		scm/turtle scm/turtlegr.c scm/grtest.scm
-	zip -d /c/scm/dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info
+	zip -d /c/scm/dist/scm$(VERSION).zip scm/scm.info scm/Xlibscm.info scm/hobbit.info
 pubzip:	$(HOME)/pub/scm.zip
 $(HOME)/pub/scm.zip:	temp/scm
 	$(makedev) DEST=$(HOME)/pub/ PROD=scm zip
@@ -421,45 +518,31 @@ pubdiffs:	temp/scm
 distdiffs:	temp/scm
 	$(makedev) DEST=$(dest) PROD=scm ver=$(ver) distdiffs
 
+CITERS = ANNOUNCE ../jacal/ANNOUNCE \
+	../wb/README ../wb/ANNOUNCE ../synch/ANNOUNCE \
+	$(htmldir)README.html ../dist/README \
+	$(htmldir)SLIB.html $(htmldir)JACAL.html \
+	$(htmldir)SCM.html $(htmldir)SIMSYNCH.html \
+	../jacal/jacal.texi ../wb/wb.texi \
+	/c/scm/dist/install.bat /c/scm/dist/makefile \
+	/c/scm/dist/mkdisk.bat hobbit.texi hobbit.scm
+
+updates:	Init$(ver).scm
+	$(CHPAT) scm$(VERSION) scm$(ver) $(CITERS)
+	$(CHPAT) scm-$(VERSION) scm-$(ver) $(CITERS)
+	$(CHPAT) $(VERSION) $(ver) ../wb/wb.spec $(htmldir)SCM.html scm.spec
+
+Init$(ver).scm:
+	mv -f Init$(VERSION).scm Init$(ver).scm
+	$(CHPAT) $(VERSION) $(ver) patchlvl.h Init$(ver).scm
 
-HOBBITVERSION = 5x
-hobfiles = README.hob hobbit.doc hobbit.tms hobbit.scm scmhob.h
-#hobfiles = hobbit.doc COPYING Makefile.hob hobbit.scm scmhob.h scmhob.scm
-
-hobtemp/scm:	$(hobfiles)
-	-$(RM_R) hobtemp
-	mkdir hobtemp
-	mkdir hobtemp/scm
-	ln $(hobfiles) hobtemp/scm
-
-hobdist:	$(dest)hobbit$(HOBBITVERSION).zip
-$(dest)hobbit$(HOBBITVERSION).zip:	hobtemp/scm
-	$(makedev) DEST=$(dest) PROD=scm ver=-hob$(HOBBITVERSION) \
-		zip TEMP=hobtemp/
-	mv $(dest)scm-hob$(HOBBITVERSION).zip \
-		$(dest)hobbit$(HOBBITVERSION).zip
-hobbit$(HOBBITVERSION).zip:	hobtemp/scm
-	$(makedev) TEMP=hobtemp/ name=hobbit$(HOBBITVERSION) PROD=scm zip
-
-new:
-	echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change
+new:	updates
+	echo `date -I` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change
 	echo>> change
 	echo \	\* patchlvl.h \(SCMVERSION\): Bumped from $(VERSION) to $(ver).>>change
 	echo>> change
 	cat ChangeLog >> change
 	mv -f change ChangeLog
-	$(CHPAT) scm$(VERSION) scm$(ver) ANNOUNCE ../jacal/ANNOUNCE \
-		../wb/README ../wb/ANNOUNCE \
-		$(htmldir)README.html ../dist/README \
-		$(htmldir)SLIB.html $(htmldir)JACAL.html \
-		$(htmldir)SCM.html $(htmldir)Hobbit.html \
-		$(htmldir)SIMSYNCH.html \
-		/c/scm/dist/install.bat /c/scm/dist/makefile \
-		/c/scm/dist/mkdisk.bat hobbit.doc
-	cp -f hobbit.doc $(htmldir)hobbit.txt
-	mv -f Init$(VERSION).scm Init$(ver).scm
-	$(CHPAT) $(VERSION) $(ver) patchlvl.h \
-		Init$(ver).scm $(htmldir)SCM.html
 	cvs remove Init$(VERSION).scm
 	cvs add Init$(ver).scm
 	cvs commit -m 'Init$(VERSION).scm changed to Init$(ver).scm' \
@@ -505,15 +588,18 @@ name8s:	scmlit
 		}else p=1;\
 		l=$$1\
 	     }END{exit stat}' -
-ctags:	$(hfiles) $(cfiles) $(xfiles)
-	etags $(hfiles) $(cfiles) $(xfiles)
-TAGS:
-tags:	$(hfiles) $(cfiles) $(ifiles) $(vfiles) turtlegr.c\
-	version.txi scm.texi Xlibscm.texi build.scm build $(xfiles)
-#	# $(ufiles) $(mfiles) ChangeLog hobbit.scm
-	etags $(hfiles) $(cfiles) $(ifiles) $(vfiles) turtlegr.c\
-	Xlibscm.texi scm.texi build.scm build $(xfiles)
-# 	# $(ufiles) $(mfiles) ChangeLog hobbit.scm
+
+ctagfiles = $(hfiles) $(cfiles) $(xfiles)
+ctags:	$(ctagfiles)
+	etags $(ctagfiles)
+
+TAGFILES = $(hfiles) $(cfiles) $(ifiles) $(vfiles)\
+	version.txi scm.texi Xlibscm.texi hobbit.texi build $(xfiles) $(mfiles)
+#	# $(ufiles) ChangeLog hobbit.scm
+TAGS:	$(TAGFILES)
+	etags $(TAGFILES)
+tags:	TAGS
+
 mostlyclean:
 clean:
 	-rm -f core a.out ramap.o ramap.obj $(ofiles) scmmain.o lints
diff --git a/README b/README
index f981fd9..4cadd59 100644
--- a/README
+++ b/README
@@ -1,90 +1,93 @@
-This directory contains the distribution of scm5d2.  Scm conforms to
+This directory contains the distribution of scm5d6.  Scm conforms to
 Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178
 specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2,
 NOS/VE, Unicos, VMS, Unix and similar systems.
 
-             `http://swissnet.ai.mit.edu/~jaffer/SCM.html'
+             <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
 
 Manifest
 ========
 
-`.gdbinit'       provides commands for debugging SCM with GDB             
-`COPYING'        details the LACK OF WARRANTY for SCM and the conditions  
-                 for distributing SCM.                                    
-`ChangeLog'      changes to SCM.                                          
-`Iedline.scm'    Gnu readline input editing.                              
-`Init.scm'       Scheme initialization.                                   
-`Link.scm'       compiles and dynamically links.                          
-`Macro.scm'      Supports Syntax-Rules Macros.                            
-`Makefile'       builds SCMLIT using the `make' program.                  
-`QUICKREF'       Quick Reference card for R4RS and IEEE Scheme.           
-`README'         contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints    
-                 for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE.   
-`Transcen.scm'   inexact builtin procedures.                              
-`bench.scm'      computes and records performance statistics of pi.scm.   
-`build.bat'      invokes build.scm for MS-DOS                             
-`build.scm'      database for compiling and linking new SCM programs.     
-`continue.c'     continuations.                                           
-`continue.h'     continuations.                                           
-`crs.c'          interactive terminal control.                            
-`dynl.c'         dynamically load object files.                           
-`ecrt0.c'        discover the start of initialized data space             
-                 dynamically at runtime.                                  
-`edline.c'       Gnu readline input editing (get                          
-                 ftp.sys.toronto.edu:/pub/rc/editline.shar).              
-`eval.c'         evaluator, apply, map, and foreach.                      
-`example.scm'    example from R4RS which uses inexact numbers.            
-`findexec.c'     find the executable file function.                       
-`gmalloc.c'      Gnu malloc(); used for unexec.                           
-`gsubr.c'        make_gsubr for arbitrary (< 11) arguments to C           
-                 functions.                                               
-`ioext.c'        system calls in common between PC compilers and unix.    
-`mkimpcat.scm'   build SCM-specific catalog for SLIB.                     
-`patchlvl.h'     patchlevel of this release.                              
-`pi.c'           computes digits of pi [cc -o pi pi.c;time pi 100 5].     
-`pi.scm'         computes digits of pi [type (pi 100 5)].  Test           
-                 performance against pi.c.                                
-`posix.c'        posix library interface.                                 
-`pre-crt0.c'     loaded before crt0.o on machines which do not remap      
-                 part of the data space into text space in unexec.        
-`r4rstest.scm'   tests conformance with Scheme specifications.            
-`ramap.c'        array mapping                                            
-`record.c'       proposed `Record' user definable datatypes.              
-`repl.c'         error, read-eval-print loop, read, write and load.       
-`rgx.c'          string regular expression match.                         
-`rope.c'         C interface functions.                                   
-`sc2.c'          procedures from R2RS and R3RS not in R4RS.               
-`scl.c'          inexact arithmetic                                       
-`scm.1'          unix style man page.                                     
-`scm.c'          initialization, interrupts, and non-IEEE utility         
-                 functions.                                               
-`scm.doc'        man page generated from scm.1.                           
-`scm.h'          data type and external definitions of SCM.               
-`scm.texi'       SCM installation and use.                                
-`scmfig.h'       contains system dependent definitions.                   
-`scmmain.c'      initialization, interrupts, and non-IEEE utility         
-                 functions.                                               
-`script.c'       utilities for running as `#!' script.                    
-`setjump.h'      continuations, stacks, and memory allocation.            
-`setjump.mar'    provides setjump and longjump which do not use $unwind   
-                 utility on VMS.                                          
-`setjump.s'      provides setjump and longjump for the Cray YMP.          
-`socket.c'       BSD socket interface.                                    
-`split.scm'      example use of crs.c.  Input, output, and diagnostic     
-                 output directed to separate windows.                     
-`subr.c'         the rest of IEEE functions.                              
-`sys.c'          call-with-current-continuation, opening and closing      
-                 files, storage allocation and garbage collection.        
-`time.c'         functions dealing with time.                             
-`ugsetjump.s'    provides setjump and longjump which work on Ultrix VAX.  
-`unexalpha.c'    Convert a running program into an Alpha executable file. 
-`unexec.c'       Convert a running program into an executable file.       
-`unexelf.c'      Convert a running ELF program into an executable file.   
-`unexhp9k800.c'  Convert a running HP-UX program into an executable file. 
-`unexsgi.c'      Convert a running program into an IRIX executable file.  
-`unexsunos4.c'   Convert a running program into an executable file.       
-`unif.c'         uniform vectors.                                         
-`unix.c'         non-posix system calls on unix systems.                  
+`.gdbinit'       provides commands for debugging SCM with GDB
+`COPYING'        details the LACK OF WARRANTY for SCM and the conditions
+                 for distributing SCM.
+`ChangeLog'      changes to SCM.
+`Iedline.scm'    Gnu readline input editing.
+`Init.scm'       Scheme initialization.
+`Link.scm'       Dynamic link/loading.
+`Macro.scm'      Supports Syntax-Rules Macros.
+`Makefile'       builds SCMLIT using the `make' program.
+`QUICKREF'       Quick Reference card for R4RS and IEEE Scheme.
+`README'         contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints
+                 for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE.
+`Transcen.scm'   inexact builtin procedures.
+`bench.scm'      computes and records performance statistics of pi.scm.
+`build.bat'      invokes build.scm for MS-DOS
+`build.scm'      database for compiling and linking new SCM programs.
+`compile.scm'    Hobbit compilation to C.
+`continue.c'     continuations.
+`continue.h'     continuations.
+`crs.c'          interactive terminal control.
+`debug.c'        debugging, printing code.
+`dynl.c'         dynamically load object files.
+`ecrt0.c'        discover the start of initialized data space
+                 dynamically at runtime.
+`edline.c'       Gnu readline input editing (get
+                 ftp.sys.toronto.edu:/pub/rc/editline.shar).
+`eval.c'         evaluator, apply, map, and foreach.
+`example.scm'    example from R4RS which uses inexact numbers.
+`findexec.c'     find the executable file function.
+`gmalloc.c'      Gnu malloc(); used for unexec.
+`gsubr.c'        make_gsubr for arbitrary (< 11) arguments to C
+                 functions.
+`ioext.c'        system calls in common between PC compilers and unix.
+`mkimpcat.scm'   build SCM-specific catalog for SLIB.
+`patchlvl.h'     patchlevel of this release.
+`pi.c'           computes digits of pi [cc -o pi pi.c;time pi 100 5].
+`pi.scm'         computes digits of pi [type (pi 100 5)].  Test
+                 performance against pi.c.
+`posix.c'        posix library interface.
+`pre-crt0.c'     loaded before crt0.o on machines which do not remap
+                 part of the data space into text space in unexec.
+`r4rstest.scm'   tests conformance with Scheme specifications.
+`ramap.c'        array mapping
+`record.c'       proposed `Record' user definable datatypes.
+`repl.c'         error, read-eval-print loop, read, write and load.
+`rgx.c'          string regular expression match.
+`rope.c'         C interface functions.
+`sc2.c'          procedures from R2RS and R3RS not in R4RS.
+`scl.c'          inexact arithmetic
+`scm.1'          unix style man page.
+`scm.c'          initialization, interrupts, and non-IEEE utility
+                 functions.
+`scm.doc'        man page generated from scm.1.
+`scm.h'          data type and external definitions of SCM.
+`scm.texi'       SCM installation and use.
+`scmfig.h'       contains system dependent definitions.
+`scmmain.c'      initialization, interrupts, and non-IEEE utility
+                 functions.
+`script.c'       utilities for running as `#!' script.
+`setjump.h'      continuations, stacks, and memory allocation.
+`setjump.mar'    provides setjump and longjump which do not use $unwind
+                 utility on VMS.
+`setjump.s'      provides setjump and longjump for the Cray YMP.
+`socket.c'       BSD socket interface.
+`split.scm'      example use of crs.c.  Input, output, and diagnostic
+                 output directed to separate windows.
+`subr.c'         the rest of IEEE functions.
+`sys.c'          call-with-current-continuation, opening and closing
+                 files, storage allocation and garbage collection.
+`time.c'         functions dealing with time.
+`ugsetjump.s'    provides setjump and longjump which work on Ultrix VAX.
+`unexalpha.c'    Convert a running program into an Alpha executable file.
+`unexec.c'       Convert a running program into an executable file.
+`unexelf.c'      Convert a running ELF program into an executable file.
+`unexhp9k800.c'  Convert a running HP-UX program into an executable file.
+`unexsgi.c'      Convert a running program into an IRIX executable file.
+`unexsunos4.c'   Convert a running program into an executable file.
+`unif.c'         uniform vectors.
+`unix.c'         non-posix system calls on unix systems.
+
 
 
 File: scm.info,  Node: SLIB,  Next: Building SCM,  Prev: Making SCM,  Up: Installing SCM
@@ -94,22 +97,22 @@ 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
+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:
 
-   * swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz
+   * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz
 
-   * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz
+   * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
 
-   * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz
+   * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz
 
-Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.zip') in an
+Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.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 `Init5d2.scm' is
+(this is the same directory as where the file `Init5d6.scm' is
 installed).  `require.scm' should have the contents:
 
      (define (library-vicinity) "/usr/local/lib/slib/")
@@ -140,36 +143,25 @@ 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.
+"scmlit", a "bare-bones" version of SCM sufficient for running `build'.
+`build' 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:
+need to compile SCM without build, there are several ways to proceed:
 
-   * Use SCM on a different platform to run `build.scm' to create a
-     script to build SCM;
+   * Use the build (http://swissnet.ai.mit.edu/~jaffer/buildscm.html)
+     web page to create custom batch scripts for compiling SCM.
 
-   * Use another implementation of Scheme to run `build.scm' to create a
+   * Use SCM on a different platform to run `build' to create a script
+     to build SCM;
+
+   * Use another implementation of Scheme to run `build' 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 the
-     `ANNOUNCE' file in the distribution for details.
-
-   * Use scmconfig (From: bos@scrg.cs.tcd.ie):
-
-     Build and install scripts using GNU "autoconf" are available from
-     `scmconfig4e3.tar.gz' in the distribution directories.  See
-     `README.unix' in `scmconfig4e3.tar.gz' for further instructions.
-
-     *Note:* The last release of scmconfig (4e3) was on March 20, 1996.
-     I am moving it to the OLD subdirectory until someone submits an
-     update.
-
 
 
 File: scm.info,  Node: Editing Scheme Code,  Next: Debugging Scheme Code,  Prev: SCM Session,  Up: Operational Features
@@ -177,11 +169,11 @@ File: scm.info,  Node: Editing Scheme Code,  Next: Debugging Scheme Code,  Prev:
 Editing Scheme Code
 ===================
 
- - Function: ed ARG1 ...
+ - Function: ed arg1 ...
      The value of the environment variable `EDITOR' (or just `ed' if it
      isn't defined) is invoked as a command with arguments ARG1 ....
 
- - Function: ed FILENAME
+ - Function: ed filename
      If SCM is compiled under VMS `ed' will invoke the editor with a
      single the single argument FILENAME.
 
@@ -190,11 +182,11 @@ Gnu Emacs:
      files ending in .scm are automatically put into scheme-mode.
      EMACS for MS-DOS and MS-Windows systems is available (free) from:
 
-              `http://simtel.coast.net/SimTel/gnu/demacs.html'
+              <http://simtel.coast.net/SimTel/gnu/demacs.html>
 
      If your Emacs can run a process in a buffer you can use the Emacs
-command `M-x run-scheme' with SCM.  Otherwise, use the emacs command
-`M-x suspend-emacs'; or see "other systems" below.
+     command `M-x run-scheme' with SCM.  Otherwise, use the emacs
+     command `M-x suspend-emacs'; or see "other systems" below.
 
 Epsilon (MS-DOS):
      There is lisp (and scheme) mode available by use of the package
@@ -213,7 +205,7 @@ Epsilon (MS-DOS):
 
 other systems:
      Define the environment variable `EDITOR' to be the name of the
-     editing program you use.  The SCM procedure `(ed arg1 ...)'  will
+     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:
 
@@ -229,32 +221,32 @@ File: scm.info,  Node: Problems Compiling,  Next: Problems Linking,  Prev: Autom
 Problems Compiling
 ==================
 
-FILE    PROBLEM / MESSAGE                HOW TO FIX                       
-*.c     include file not found.          Correct the status of            
-                                         STDC_HEADERS in scmfig.h.        
-                                         fix #include statement or add    
-                                         #define for system type to       
-                                         scmfig.h.                        
-*.c     Function should return a value.  Ignore.                          
-        Parameter is never used.                                          
-        Condition is always false.                                        
-        Unreachable code in function.                                     
-scm.c   assignment between incompatible  Change SIGRETTYPE in scm.c.      
-        types.                                                            
-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.                 
-subr.c  Possibly incorrect assignment    Ignore.                          
-        in function lgcd.                                                 
-sys.c   statement not reached.           Ignore.                          
-        constant in conditional                                           
-        expression.                                                       
-sys.c   undeclared, outside of           #undef STDC_HEADERS in scmfig.h. 
-        functions.                                                        
-scl.c   syntax error.                    #define SYSTNAME to your system  
-                                         type in scl.c (softtype).        
+FILE    PROBLEM / MESSAGE                HOW TO FIX
+*.c     include file not found.          Correct the status of
+                                         STDC_HEADERS in scmfig.h.
+                                         fix #include statement or add
+                                         #define for system type to
+                                         scmfig.h.
+*.c     Function should return a value.  Ignore.
+        Parameter is never used.         
+        Condition is always false.       
+        Unreachable code in function.    
+scm.c   assignment between incompatible  Change SIGRETTYPE in scm.c.
+        types.                           
+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.
+subr.c  Possibly incorrect assignment    Ignore.
+        in function lgcd.                
+sys.c   statement not reached.           Ignore.
+        constant in conditional          
+        expression.                      
+sys.c   undeclared, outside of           #undef STDC_HEADERS in scmfig.h.
+        functions.                       
+scl.c   syntax error.                    #define SYSTNAME to your system
+                                         type in scl.c (softtype).
 
 
 
@@ -263,8 +255,8 @@ File: scm.info,  Node: Problems Linking,  Next: Problems Running,  Prev: Problem
 Problems Linking
 ================
 
-PROBLEM                              HOW TO FIX                           
-_sin etc. missing.                   Uncomment LIBS in makefile.          
+PROBLEM                              HOW TO FIX
+_sin etc. missing.                   Uncomment LIBS in makefile.
 
 
 
@@ -273,38 +265,38 @@ File: scm.info,  Node: Problems Running,  Next: Testing,  Prev: Problems Linking
 Problems Running
 ================
 
-PROBLEM                              HOW TO FIX                           
-Opening message and then machine     Change memory model option to C      
-crashes.                             compiler (or makefile).              
-                                     Make sure sizet definition is        
-                                     correct in scmfig.h.                 
-                                     Reduce the size of HEAP_SEG_SIZE in  
-                                     setjump.h.                           
-Input hangs.                         #define NOSETBUF                     
-ERROR: heap: need larger initial.    Increase initial heap allocation     
-                                     using -a<kb> or INIT_HEAP_SIZE.      
-ERROR: Could not allocate.           Check sizet definition.              
-                                     Use 32 bit compiler mode.            
-                                     Don't try to run as subproccess.     
-remove <FLAG> in scmfig.h and        Do so and recompile files.           
-recompile scm.                                                            
-add <FLAG> in scmfig.h and                                                
-recompile scm.                                                            
-ERROR: Init5d2.scm not found.        Assign correct IMPLINIT in makefile  
-                                     or scmfig.h.                         
-                                     Define environment variable          
-                                     SCM_INIT_PATH to be the full         
-                                     pathname of Init5d2.scm.             
-WARNING: require.scm not found.      Define environment variable          
-                                     SCHEME_LIBRARY_PATH to be the full   
-                                     pathname of the scheme library       
-                                     [SLIB].                              
-                                     Change library-vicinity in           
-                                     Init5d2.scm to point to library or   
-                                     remove.                              
-                                     Make sure the value of               
-                                     (library-vicinity) has a trailing    
-                                     file separator (like / or \).        
+PROBLEM                              HOW TO FIX
+Opening message and then machine     Change memory model option to C
+crashes.                             compiler (or makefile).
+                                     Make sure sizet definition is
+                                     correct in scmfig.h.
+                                     Reduce the size of HEAP_SEG_SIZE in
+                                     setjump.h.
+Input hangs.                         #define NOSETBUF
+ERROR: heap: need larger initial.    Increase initial heap allocation
+                                     using -a<kb> or INIT_HEAP_SIZE.
+ERROR: Could not allocate.           Check sizet definition.
+                                     Use 32 bit compiler mode.
+                                     Don't try to run as subproccess.
+remove <FLAG> in scmfig.h and        Do so and recompile files.
+recompile scm.                       
+add <FLAG> in scmfig.h and           
+recompile scm.                       
+ERROR: Init5d6.scm not found.        Assign correct IMPLINIT in makefile
+                                     or scmfig.h.
+                                     Define environment variable
+                                     SCM_INIT_PATH to be the full
+                                     pathname of Init5d6.scm.
+WARNING: require.scm not found.      Define environment variable
+                                     SCHEME_LIBRARY_PATH to be the full
+                                     pathname of the scheme library
+                                     [SLIB].
+                                     Change library-vicinity in
+                                     Init5d6.scm to point to library or
+                                     remove.
+                                     Make sure the value of
+                                     (library-vicinity) has a trailing
+                                     file separator (like / or \).
 
 
 
@@ -333,13 +325,13 @@ of pi.
      > (load "pi")
      ;loading "pi"
      ;done loading "pi.scm"
-     ;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other
+     ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B 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
+     ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other
      #<unspecified>
 
 Loading `bench.scm' will compute and display performance statistics of
@@ -347,34 +339,34 @@ SCM running `pi.scm'.  `make bench' or `make benchlit' appends the
 performance report to the file `BenchLog', facilitating tracking
 effects of changes to SCM on performance.
 
-PROBLEM                              HOW TO FIX                           
-Runs some and then machine crashes.  See above under machine crashes.     
-Runs some and then ERROR: ...        Remove optimization option to C      
-(after a GC has happened).           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_... in  
-output files.                        `Init5d2.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 in        
-                                     `scmfig.h'.                          
-VAX: botched longjmp.                                                     
+PROBLEM                              HOW TO FIX
+Runs some and then machine crashes.  See above under machine crashes.
+Runs some and then ERROR: ...        Remove optimization option to C
+(after a GC has happened).           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_... in
+output files.                        `Init5d6.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 in
+                                     `scmfig.h'.
+VAX: botched longjmp.                
 
 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
+     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/Transcen.scm b/Transcen.scm
index 7898251..b0d1a2b 100644
--- a/Transcen.scm
+++ b/Transcen.scm
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -43,6 +43,11 @@
 
 (define compile-allnumbers #t)		;for HOBBIT compiler
 
+(define $pi (* 4 ($atan 1)))
+(define pi $pi)
+(define (pi* z) (* $pi z))
+(define (pi/ z) (/ $pi z))
+
 (define (exp z)
   (if (real? z) ($exp z)
       (make-polar ($exp (real-part z)) (imag-part z))))
diff --git a/Xlibscm.info b/Xlibscm.info
index 4c57ced..1052cba 100644
--- a/Xlibscm.info
+++ b/Xlibscm.info
@@ -1,5 +1,5 @@
-This is Info file Xlibscm.info, produced by Makeinfo version 1.68 from
-the input file Xlibscm.texi.
+This is Xlibscm.info, produced by makeinfo version 4.0 from
+Xlibscm.texi.
 
 INFO-DIR-SECTION The Algorithmic Language Scheme
 START-INFO-DIR-ENTRY
@@ -12,7 +12,7 @@ File: Xlibscm.info,  Node: Top,  Next: Xlibscm,  Prev: (dir),  Up: (dir)
 This manual documents the X - SCM Language X Interface.  The most recent
 information about SCM can be found on SCM's "WWW" home page:
 
-             `http://swissnet.ai.mit.edu/~jaffer/SCM.html'
+             <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
 
 Copyright (C) 1990-1999 Free Software Foundation
 
@@ -33,19 +33,18 @@ approved by the author.
 * Menu:
 
 * Xlibscm::
-* Display::
-* Screen::
-* Window::
-* Window Visibility::
+* Display and Screens::
+* Drawables::
 * Graphics Context::
 * Cursor::
 * Colormap::
 * Rendering::
+* Images::
 * Event::
 * Index::
 
 
-File: Xlibscm.info,  Node: Xlibscm,  Next: Display,  Prev: Top,  Up: Top
+File: Xlibscm.info,  Node: Xlibscm,  Next: Display and Screens,  Prev: Top,  Up: Top
 
 Xlibscm
 *******
@@ -111,12 +110,12 @@ the suitability of this documentation for any purpose.  It is provided
 "as is" without express or implied warranty.
 
 
-File: Xlibscm.info,  Node: Display,  Next: Screen,  Prev: Xlibscm,  Up: Top
+File: Xlibscm.info,  Node: Display and Screens,  Next: Drawables,  Prev: Xlibscm,  Up: Top
 
-Display
-*******
+Display and Screens
+*******************
 
- - Function: x:open-display DISPLAY-NAME
+ - Function: x:open-display display-name
      DISPLAY-NAME Specifies the hardware display name, which determines
      the display and communications domain to be used.  On a
      POSIX-conformant system, if the display-name is #f, it defaults to
@@ -142,7 +141,7 @@ Display
           SCREEN-NUMBER sets an internal variable that can be accessed
           by using the x:default-screen procedure.
 
- - Function: x:close DISPLAY
+ - Function: x:close display
      DISPLAY specifies the connection to the X server.
 
      The `x:close' function closes the connection to the X server for
@@ -155,39 +154,32 @@ Display
      generated.  Before exiting, you should call X:CLOSE-DISPLAY or
      X:FLUSH explicitly so that any pending errors are reported.
 
- - Function: x:protocol-version DISPLAY
+ - Function: x:protocol-version display
      Returns cons of the major version number (11) of the X protocol
      associated with the connected DISPLAY and the minor protocol
      revision number of the X server.
 
- - Function: x:server-vendor DISPLAY
+ - Function: x:server-vendor display
      Returns a string that provides some identification of the owner of
      the X server implementation.  The contents of the string are
      implementation-dependent.
 
- - Function: x:vendor-release DISPLAY
+ - Function: x:vendor-release display
      Returns a number related to a vendor's release of the X server.
 
-
-File: Xlibscm.info,  Node: Screen,  Next: Window,  Prev: Display,  Up: Top
-
-Screen
-******
-
 A display consists of one or more "Screen"s.  Each screen has a
-"root-window", "default-graphics-context", "default-visual", and
-"colormap".
+"root-window", "default-graphics-context", and "colormap".
 
- - Function: x:screen-count DISPLAY
+ - Function: x:screen-count display
      Returns the number of available screens.
 
- - Function: x:default-screen DISPLAY
+ - Function: x:default-screen display
      Returns the default screen number specified by the `x:open-display'
      function.  Use this screen number in applications which will use
      only a single screen.
 
- - Function: x:root-window DISPLAY SCREEN-NUMBER
- - Function: x:root-window DISPLAY
+ - Function: x:root-window display screen-number
+ - Function: x:root-window display
      SCREEN-NUMBER, if givien, specifies the appropriate screen number
      on the host server.  Otherwise the default-screen for DISPLAY is
      used.
@@ -196,34 +188,40 @@ A display consists of one or more "Screen"s.  Each screen has a
      `x:root-window' for functions that need a drawable of a particular
      screen or for creating top-level windows.
 
- - Function: x:root-window WINDOW
+ - Function: x:root-window window
      Returns the root window for the specified WINDOW's screen.
 
- - Function: x:default-colormap DISPLAY SCREEN-NUMBER
- - Function: x:default-colormap DISPLAY
- - Function: x:default-colormap WINDOW
+ - Function: x:default-colormap display screen-number
+ - Function: x:default-colormap display
+ - Function: x:default-colormap window
      Returns the default colormap of the specified screen.
 
- - Function: x:default-gc DISPLAY SCREEN-NUMBER
- - Function: x:default-gc DISPLAY
- - Function: x:default-gc WINDOW
+ - Function: x:default-ccc display screen-number
+ - Function: x:default-ccc display
+ - Function: x:default-ccc window
+     Returns the default Color-Conversion-Context (ccc) of the specified
+     screen.
+
+ - Function: x:default-gc display screen-number
+ - Function: x:default-gc display
+ - Function: x:default-gc window
      Returns the default graphics-context of the specified screen.
 
- - Function: x:default-depths DISPLAY SCREEN-NUMBER
- - Function: x:default-depths DISPLAY
- - Function: x:default-depths WINDOW
-     Returns a vector of depths supported by the specified screen.
+ - Function: x:screen-depths display screen-number
+ - Function: x:screen-depths display
+ - Function: x:screen-depths window
+     Returns an array of depths supported by the specified screen.
 
 The "Visual" type describes possible colormap depths and arrangements.
 
- - Function: x:default-visual DISPLAY SCREEN-NUMBER
- - Function: x:default-visual DISPLAY
- - Function: x:default-visual WINDOW
+ - Function: x:default-visual display screen-number
+ - Function: x:default-visual display
+ - Function: x:default-visual window
      Returns the default Visual type for the specified screen.
 
 
- - Function: x:make-visual DISPLAY DEPTH CLASS
- - Function: x:make-visual WINDOW DEPTH CLASS
+ - Function: x:make-visual display depth class
+ - Function: x:make-visual window depth class
      The integer DEPTH specifies the number of bits per pixel.  The
      CLASS argument specifies one of the possible visual classes for a
      screen:
@@ -242,52 +240,83 @@ The "Visual" type describes possible colormap depths and arrangements.
      `X:make-visual' returns a visual type for the screen specified by
      DISPLAY or WINDOW if successful; #f if not.
 
+ - Function: x:visual-class visual
+ - Function: x:visual-class screen
+ - Function: x:visual-class display
+     Returns the (integer) visual class of its argument.
+
+ - Function: x:visual-geometry visual
+ - Function: x:visual-geometry screen
+ - Function: x:visual-geometry display
+     Returns a list of the:
+        * red_mask
+
+        * green_mask
 
- - Function: x:screen-cells DISPLAY SCREEN-NUMBER
- - Function: x:screen-cells DISPLAY
- - Function: x:screen-cells WINDOW
+        * blue_mask
+
+        * colormap_size
+
+ - Function: x:screen-cells display screen-number
+ - Function: x:screen-cells display
+ - Function: x:screen-cells window
      Returns the number of entries in the default colormap.
 
- - Function: x:screen-depth DISPLAY SCREEN-NUMBER
- - Function: x:screen-depth DISPLAY
- - Function: x:screen-depth WINDOW
+ - Function: x:screen-depth display screen-number
      Returns the depth of the root window of the specified screen.
 
+ - Function: x:screen-depth display
+ - Function: x:screen-depth window
+ - Function: x:screen-depth visual
+     Returns the depth of argument.
+
      The "depth" of a window or pixmap is the number of bits per pixel
      it has.  The "depth" of a graphics context is the depth of the
      drawables it can be used in conjunction with graphics output.
 
- - Function: x:screen-size DISPLAY SCREEN-NUMBER
- - Function: x:screen-size DISPLAY
- - Function: x:screen-size WINDOW
+ - Function: x:screen-size display screen-number
+ - Function: x:screen-size display
+ - Function: x:screen-size window
      Returns a list of integer height and width of the screen in pixels.
 
- - Function: x:screen-dimensions DISPLAY SCREEN-NUMBER
- - Function: x:screen-dimensions DISPLAY
- - Function: x:screen-dimensions WINDOW
+ - Function: x:screen-dimensions display screen-number
+ - Function: x:screen-dimensions display
+ - Function: x:screen-dimensions window
      Returns a list of integer height and width of the screen in
      millimeters.
 
- - Function: x:screen-white DISPLAY SCREEN-NUMBER
- - Function: x:screen-white DISPLAY
- - Function: x:screen-white WINDOW
+ - Function: x:screen-white display screen-number
+ - Function: x:screen-white display
+ - Function: x:screen-white window
      Returns the white pixel value of the specified screen.
 
- - Function: x:screen-black DISPLAY SCREEN-NUMBER
- - Function: x:screen-black DISPLAY
- - Function: x:screen-black WINDOW
+ - Function: x:screen-black display screen-number
+ - Function: x:screen-black display
+ - Function: x:screen-black window
      Returns the black pixel value of the specified screen.
 
 
-File: Xlibscm.info,  Node: Window,  Next: Window Visibility,  Prev: Screen,  Up: Top
+File: Xlibscm.info,  Node: Drawables,  Next: Graphics Context,  Prev: Display and Screens,  Up: Top
 
-Window
-******
+Drawables
+*********
 
 A "Drawable" is either a window or pixmap.
 
- - Function: x:create-window WINDOW POSITION SIZE BORDER-WIDTH DEPTH
-          CLASS VISUAL FIELD-NAME VALUE ...
+* Menu:
+
+* Windows and Pixmaps::
+* Window Attributes::
+* Window Properties and Visibility::
+
+
+File: Xlibscm.info,  Node: Windows and Pixmaps,  Next: Window Attributes,  Prev: Drawables,  Up: Drawables
+
+Windows and Pixmaps
+===================
+
+ - Function: x:create-window window position size border-width depth
+          class visual field-name value ...
      Creates and returns an unmapped Input-Output subwindow for a
      specified parent WINDOW and causes the X server to generate a
      CreateNotify event.  The created window is placed on top in the
@@ -312,14 +341,14 @@ A "Drawable" is either a window or pixmap.
      The returned window will have the attributes specified by
      FIELD-NAMEs and VALUE.
 
- - Function: x:create-window WINDOW POSITION SIZE BORDER-WIDTH BORDER
-          BACKGROUND
+ - Function: x:create-window window position size border-width border
+          background
      The returned window inherits its depth, class, and visual from its
      parent.  All other window attributes, except BACKGROUND and
      BORDER, have their default values.
 
- - Function: x:create-pixmap DRAWABLE SIZE DEPTH
- - Function: x:create-pixmap DISPLAY SIZE DEPTH
+ - Function: x:create-pixmap drawable size depth
+ - Function: x:create-pixmap display size depth
      SIZE is a list, vector, or pair of nonzero integers specifying the
      width and height desired in the new pixmap.
 
@@ -328,7 +357,7 @@ A "Drawable" is either a window or pixmap.
      drawable argument.  The DEPTH argument must be one of the depths
      supported by the screen of the specified DRAWABLE.
 
- - Function: x:close WINDOW
+ - Function: x:close window
      Destroys the specified WINDOW as well as all of its subwindows and
      causes the X server to generate a DestroyNotify event for each
      window.  The window should not be used again.  If the window
@@ -342,21 +371,21 @@ A "Drawable" is either a window or pixmap.
      mapped WINDOW will generate x:Expose events on other windows that
      were obscured by the window being destroyed.
 
- - Function: x:close PIXMAP
+ - Function: x:close pixmap
      Deletes the association between the PIXMAP and its storage.  The X
      server frees the pixmap storage when there are no references to it.
 
- - Function: x:window-geometry DRAWABLE
+ - Function: x:window-geometry drawable
      Returns a list of:
 
     coordinates
-          `cons' of x and y coordinates that define the location of the
+          `list' of x and y coordinates that define the location of the
           DRAWABLE.  For a window, these coordinates specify the
           upper-left outer corner relative to its parent's origin.  For
           pixmaps, these coordinates are always zero.
 
     size
-          `cons' of the DRAWABLE's dimensions (width and height).  For
+          `list' of the DRAWABLE's dimensions (width and height).  For
           a window, these dimensions specify the inside size, not
           including the border.
 
@@ -367,16 +396,103 @@ A "Drawable" is either a window or pixmap.
     depth
           The depth of the DRAWABLE (bits per pixel for the object).
 
- - Function: x:window-set! WINDOW FIELD-NAME VALUE ...
+ - Function: x:window-geometry-set! window field-name value ...
+     Changes the "Configuration" components specified by FIELD-NAMEs
+     for the specified WINDOW.
+
+These are the attributes settable by `x:window-geometry-set!'.  That
+these attributes are encoded by small integers - just like those of the
+next section.  Be warned therefore that confusion of attribute names
+will likely not signal errors, just cause mysterious behavior.
+
+ - Attribute: x:CWX
+ - Attribute: x:CWY
+ - Attribute: x:CW-Width
+ - Attribute: x:CW-Height
+     The x:CWX and x:CYY members are used to set the window's x and y
+     coordinates, which are relative to the parent's origin and
+     indicate the position of the upper-left outer corner of the
+     window.  The x:CW-Width and x:CW-Height members are used to set
+     the inside size of the window, not including the border, and must
+     be nonzero.  Attempts to configure a root window have no effect.
+
+     If a window's size actually changes, the window's subwindows move
+     according to their window gravity.  Depending on the window's bit
+     gravity, the contents of the window also may be moved
+
+ - Attribute: x:CW-Border-Width
+     The integer x:CW-Border-Width is used to set the width of the
+     border in pixels.  Note that setting just the border width leaves
+     the outer-left corner of the window in a fixed position but moves
+     the absolute position of the window's origin.  It is an error to
+     set the border-width attribute of an InputOnly window nonzero.
+
+ - Attribute: x:CW-Sibling
+     The sibling member is used to set the sibling window for stacking
+     operations.
+
+ - Attribute: x:CW-Stack-Mode
+     The x:CW-Stack-Mode member is used to set how the window is to be
+     restacked and can be set to x:Above, x:Below, x:Top-If,
+     x:Bottom-If, or x:Opposite.
+
+If a sibling and a stack-mode are specified, the window is restacked as
+follows:
+
+`x:Above'
+     The window is placed just above the sibling.
+
+`x:Below'
+     The window is placed just below the sibling.
+
+`x:Top-If'
+     If the sibling occludes the window, the window is placed at the
+     top of the stack.
+
+`x:Bottom-If'
+     If the window occludes the sibling, the window is placed at the
+     bottom of the stack.
+
+`x:Opposite'
+     If the sibling occludes the window, the window is placed at the
+     top of the stack.  If the window occludes the sibling, the window
+     is placed at the bottom of the stack.
+
+If a stack-mode is specified but no sibling is specified, the window is
+restacked as follows:
+
+`x:Above'
+     The window is placed at the top of the stack.
+
+`x:Below'
+     The window is placed at the bottom of the stack.
+
+`x:Top-If'
+     If any sibling occludes the window, the window is placed at the
+     top of the stack.
+
+`x:Bottom-If'
+     If the window occludes any sibling, the window is placed at the
+     bottom of the stack.
+
+`x:Opposite'
+     If any sibling occludes the window, the window is placed at the
+     top of the stack.  If the window occludes any sibling, the window
+     is placed at the bottom of the stack.
+
+
+File: Xlibscm.info,  Node: Window Attributes,  Next: Window Properties and Visibility,  Prev: Windows and Pixmaps,  Up: Drawables
+
+Window Attributes
+=================
+
+ - Function: x:window-set! window field-name value ...
      Changes the components specified by FIELD-NAMEs for the specified
      WINDOW.  The restrictions are the same as for `x:create-window'.
      The order in which components are verified and altered is server
      dependent.  If an error occurs, a subset of the components may
      have been altered.
 
-Window Attributes
-=================
-
 The `x:create-window' and `x:window-set!' procedures take five and one
 argument (respectively) followed by pairs of arguments, where the first
 is one of the property-name symbols (or its top-level value) listed
@@ -427,16 +543,16 @@ below; and the second is the value to associate with that property.
      children to be reconfigured (depending on their win-gravity).  For
      a change of width and height, the (x, y) pairs are defined:
 
-     Gravity Direction                  Coordinates                        
-     x:North-West-Gravity               (0, 0)                             
-     x:North-Gravity                    (Width/2, 0)                       
-     x:North-East-Gravity               (Width, 0)                         
-     x:West-Gravity                     (0, Height/2)                      
-     x:Center-Gravity                   (Width/2, Height/2)                
-     x:East-Gravity                     (Width, Height/2)                  
-     x:South-West-Gravity               (0, Height)                        
-     x:South-Gravity                    (Width/2, Height)                  
-     x:South-East-Gravity               (Width, Height)                    
+     Gravity Direction                  Coordinates
+     x:North-West-Gravity               (0, 0)
+     x:North-Gravity                    (Width/2, 0)
+     x:North-East-Gravity               (Width, 0)
+     x:West-Gravity                     (0, Height/2)
+     x:Center-Gravity                   (Width/2, Height/2)
+     x:East-Gravity                     (Width, Height/2)
+     x:South-West-Gravity               (0, Height)
+     x:South-Gravity                    (Width/2, Height)
+     x:South-East-Gravity               (Width, Height)
 
      When a window with one of these bit-gravity values is resized, the
      corresponding pair defines the change in position of each pixel in
@@ -557,50 +673,51 @@ below; and the second is the value to associate with that property.
      the event-mask argument and the circumstances in which you would
      want to specify the event mask:
 
-     Event Mask                     Circumstances                         
-     x:No-Event-Mask                No events wanted                      
-     x:Key-Press-Mask               Keyboard down events wanted           
-     x:Key-Release-Mask             Keyboard up events wanted             
-     x:Button-Press-Mask            Pointer button down events wanted     
-     x:Button-Release-Mask          Pointer button up events wanted       
-     x:Enter-Window-Mask            Pointer window entry events wanted    
-     x:Leave-Window-Mask            Pointer window leave events wanted    
-     x:Pointer-Motion-Mask          Pointer motion events wanted          
-     x:Pointer-Motion-Hint-Mask     If x:Pointer-Motion-Hint-Mask is      
-                                    selected in combination with one or   
-                                    more motion-masks, the X server is    
-                                    free to send only one x:Motion-Notify 
-                                    event (with the is_hint member of     
-                                    the X:Pointer-Moved-Event structure   
-                                    set to x:Notify-Hint) to the client   
-                                    for the event window, until either    
-                                    the key or button state changes, the  
-                                    pointer leaves the event window, or   
-                                    the client calls X:Query-Pointer or   
-                                    X:Get-Motion-Events.  The server      
-                                    still may send x:Motion-Notify        
-                                    events without is_hint set to         
-                                    x:Notify-Hint.                        
-     x:Button1-Motion-Mask          Pointer motion while button 1 down    
-     x:Button2-Motion-Mask          Pointer motion while button 2 down    
-     x:Button3-Motion-Mask          Pointer motion while button 3 down    
-     x:Button4-Motion-Mask          Pointer motion while button 4 down    
-     x:Button5-Motion-Mask          Pointer motion while button 5 down    
-     x:Button-Motion-Mask           Pointer motion while any button down  
-     x:Keymap-State-Mask            Keyboard state wanted at window       
-                                    entry and focus in                    
-     x:Exposure-Mask                Any exposure wanted                   
-     x:Visibility-Change-Mask       Any change in visibility wanted       
-     x:Structure-Notify-Mask        Any change in window structure wanted 
-     x:Resize-Redirect-Mask         Redirect resize of this window        
-     x:Substructure-Notify-Mask     Substructure notification wanted      
-     x:Substructure-Redirect-Mask   Redirect structure requests on        
-                                    children                              
-     x:Focus-Change-Mask            Any change in input focus wanted      
-     x:Property-Change-Mask         Any change in property wanted         
-     x:Colormap-Change-Mask         Any change in colormap wanted         
-     x:Owner-Grab-Button-Mask       Automatic grabs should activate with  
-                                    owner_events set to True              
+     Event Mask                     Circumstances
+     x:No-Event-Mask                No events wanted
+     x:Key-Press-Mask               Keyboard down events wanted
+     x:Key-Release-Mask             Keyboard up events wanted
+     x:Button-Press-Mask            Pointer button down events wanted
+     x:Button-Release-Mask          Pointer button up events wanted
+     x:Enter-Window-Mask            Pointer window entry events wanted
+     x:Leave-Window-Mask            Pointer window leave events wanted
+     x:Pointer-Motion-Mask          Pointer motion events wanted
+     x:Pointer-Motion-Hint-Mask     If x:Pointer-Motion-Hint-Mask is
+                                    selected in combination with one or
+                                    more motion-masks, the X server is
+                                    free to send only one x:Motion-Notify
+                                    event (with the is_hint member of
+                                    the X:Pointer-Moved-Event structure
+                                    set to x:Notify-Hint) to the client
+                                    for the event window, until either
+                                    the key or button state changes, the
+                                    pointer leaves the event window, or
+                                    the client calls X:Query-Pointer or
+                                    X:Get-Motion-Events.  The server
+                                    still may send x:Motion-Notify
+                                    events without is_hint set to
+                                    x:Notify-Hint.
+     x:Button1-Motion-Mask          Pointer motion while button 1 down
+     x:Button2-Motion-Mask          Pointer motion while button 2 down
+     x:Button3-Motion-Mask          Pointer motion while button 3 down
+     x:Button4-Motion-Mask          Pointer motion while button 4 down
+     x:Button5-Motion-Mask          Pointer motion while button 5 down
+     x:Button-Motion-Mask           Pointer motion while any button down
+     x:Keymap-State-Mask            Keyboard state wanted at window
+                                    entry and focus in
+     x:Exposure-Mask                Any exposure wanted
+     x:Visibility-Change-Mask       Any change in visibility wanted
+     x:Structure-Notify-Mask        Any change in window structure wanted
+     x:Resize-Redirect-Mask         Redirect resize of this window
+     x:Substructure-Notify-Mask     Substructure notification wanted
+     x:Substructure-Redirect-Mask   Redirect structure requests on
+                                    children
+     x:Focus-Change-Mask            Any change in input focus wanted
+     x:Property-Change-Mask         Any change in property wanted
+     x:Colormap-Change-Mask         Any change in colormap wanted
+     x:Owner-Grab-Button-Mask       Automatic grabs should activate with
+                                    owner_events set to True
+
 
  - Attribute: x:CW-Dont-Propagate
      The do-not-propagate-mask attribute defines which events should
@@ -642,18 +759,56 @@ below; and the second is the value to associate with that property.
      in the displayed cursor.  On the root window, the default cursor
      is restored.
 
+ - Function: x:window-ref window field-name ...
+     Returns a list of the components specified by FIELD-NAMEs for the
+     specified WINDOW.  Allowable FIELD-NAMEs are a subset of those for
+     `x:window-set!':
+
+        * x:CW-Back-Pixel
+
+        * x:CW-Bit-Gravity
+
+        * x:CW-Win-Gravity
+
+        * x:CW-Backing-Store
+
+        * x:CW-Backing-Planes
+
+        * x:CW-Backing-Pixel
+
+        * x:CW-Override-Redirect
+
+        * x:CW-Save-Under
+
+        * x:CW-Event-Mask
+
+        * x:CW-Dont-Propagate
+
+        * x:CW-Colormap
+
 
-File: Xlibscm.info,  Node: Window Visibility,  Next: Graphics Context,  Prev: Window,  Up: Top
+File: Xlibscm.info,  Node: Window Properties and Visibility,  Prev: Window Attributes,  Up: Drawables
+
+Window Properties and Visibility
+================================
+
+ - Function: x:get-window-property window property
+     Returns the (string or list of numbers) value of PROPERTY of
+     WINDOW.
 
-Window Visibility
-*****************
+ - Function: x:get-window-property window property #t
+     Removes and returns the (string or list of numbers) value of
+     PROPERTY of WINDOW.
+
+ - Function: x:list-properties window
+     Returns a list of the properties (strings) defined for WINDOW.
 
 In X parlance, a window which is hidden even when not obscured by other
 windows is "unmapped"; one which shows is "mapped".  It is an
 unfortunate name-collision with Scheme, and is ingrained in the
 attribute names.
 
- - Function: x:map-window WINDOW
+ - Function: x:map-window window
      Maps the WINDOW and all of its subwindows that have had map
      requests.  Mapping a window that has an unmapped ancestor does not
      display the window but marks it as eligible for display when the
@@ -690,13 +845,7 @@ attribute names.
      be to repaint the window.  This method usually leads to simpler
      programs and to proper interaction with window managers.
 
- - Function: x:map-raised WINDOW
-     This procedure is similar to `x:map-window' in that it maps the
-     WINDOW and all of its subwindows that have had map requests.
-     However, it also raises the specified WINDOW to the top of the
-     stack.
-
- - Function: x:map-subwindows WINDOW
+ - Function: x:map-subwindows window
      Maps all subwindows of a specified WINDOW in top-to-bottom
      stacking order.  The X server generates x:Expose events on each
      newly displayed window.  This may be much more efficient than
@@ -704,7 +853,7 @@ attribute names.
      perform much of the work only once, for all of the windows, rather
      than for each window.
 
- - Function: x:unmap-window WINDOW
+ - Function: x:unmap-window window
      Unmaps the specified WINDOW and causes the X server to generate an
      UnmapNotify event.  If the specified WINDOW is already unmapped,
      `x:unmap-window' has no effect.  Normal exposure processing on
@@ -715,7 +864,7 @@ attribute names.
      generate x:Expose events on windows that were formerly obscured by
      it.
 
- - Function: x:unmap-subwindows WINDOW
+ - Function: x:unmap-subwindows window
      Unmaps all subwindows for the specified WINDOW in bottom-to-top
      stacking order.  It causes the X server to generate an UnmapNotify
      event on each subwindow and x:Expose events on formerly obscured
@@ -725,7 +874,7 @@ attribute names.
      rather than for each window.
 
 
-File: Xlibscm.info,  Node: Graphics Context,  Next: Cursor,  Prev: Window Visibility,  Up: Top
+File: Xlibscm.info,  Node: Graphics Context,  Next: Cursor,  Prev: Drawables,  Up: Top
 
 Graphics Context
 ****************
@@ -736,24 +885,24 @@ tile, stipple, clipping region, end style, join style, and so on.
 Graphics operations (for example, drawing lines) use these values to
 determine the actual drawing operation.
 
- - Function: x:create-gc DRAWABLE FIELD-NAME VALUE ...
+ - Function: x:create-gc drawable field-name value ...
      Creates and returns graphics context.  The graphics context can be
      used with any destination drawable having the same root and depth
      as the specified DRAWABLE.
 
- - Function: x:gc-set! GRAPHICS-CONTEXT FIELD-NAME VALUE ...
+ - Function: x:gc-set! graphics-context field-name value ...
      Changes the components specified by FIELD-NAMEs for the specified
      GRAPHICS-CONTEXT.  The restrictions are the same as for
      `x:create-gc'.  The order in which components are verified and
      altered is server dependent.  If an error occurs, a subset of the
      components may have been altered.
 
- - Function: x:copy-gc-fields! GCONTEXT-SRC GCONTEXT-DST FIELD-NAME ...
+ - Function: x:copy-gc-fields! gcontext-src gcontext-dst field-name ...
      Copies the components specified by FIELD-NAMEs from GCONTEXT-SRC
      to GCONTEXT-DST.  GCONTEXT-SRC and GCONTEXT-DST must have the same
      root and depth.
 
- - Function: x:gc-ref GRAPHICS-CONTEXT FIELD-NAME ...
+ - Function: x:gc-ref graphics-context field-name ...
      Returns a list of the components specified by FIELD-NAMEs ...
      from the specified GRAPHICS-CONTEXT.
 
@@ -1086,7 +1235,7 @@ File: Xlibscm.info,  Node: Cursor,  Next: Colormap,  Prev: Graphics Context,  Up
 Cursor
 ******
 
- - Function: x:create-cursor DISPLAY SHAPE
+ - Function: x:create-cursor display shape
      X provides a set of standard cursor shapes in a special font named
      "cursor".  Applications are encouraged to use this interface for
      their cursors because the font can be customized for the individual
@@ -1098,8 +1247,8 @@ Cursor
      background (see X:Recolor-Cursor).  The names of all cursor shapes
      are defined with the prefix XC: in `x11.scm'.
 
- - Function: x:create-cursor SOURCE-FONT SOURCE-CHAR MASK-FONT
-          MASK-CHAR FGC BGC
+ - Function: x:create-cursor source-font source-char mask-font
+          mask-char fgc bgc
      Creates a cursor from the source and mask bitmaps obtained from the
      specified font glyphs.  The integer SOURCE-CHAR must be a defined
      glyph in SOURCE-FONT.  The integer MASK-CHAR must be a defined
@@ -1109,11 +1258,11 @@ Cursor
      metrics, and there is no restriction on the placement of the
      hotspot relative to the bounding boxes.
 
- - Function: x:create-cursor SOURCE-FONT SOURCE-CHAR #F #F FGC BGC
+ - Function: x:create-cursor source-font source-char #f #f fgc bgc
      If MASK-FONT and MASK-CHAR are #f, all pixels of the source are
      displayed.
 
- - Function: x:create-cursor SOURCE-PIXMAP MASK-PIXMAP FGC BGC ORIGIN
+ - Function: x:create-cursor source-pixmap mask-pixmap fgc bgc origin
      MASK-PIXMAP must be the same size as the pixmap defined by the
      SOURCE-PIXMAP argument.  The foreground and background RGB values
      must be specified using FOREGROUND-COLOR and BACKGROUND-COLOR,
@@ -1128,7 +1277,7 @@ Cursor
      in MASK-PIXMAP define which source pixels are displayed, and the
      pixels set to 0 define which pixels are ignored.
 
- - Function: x:create-cursor SOURCE-PIXMAP #F FGC BGC ORIGIN
+ - Function: x:create-cursor source-pixmap #f fgc bgc origin
      If MASK-PIXMAP is #f, all pixels of the source are displayed.
 
 
@@ -1139,7 +1288,7 @@ Colormap
 
 A "colormap" maps pixel values to "RGB" color space values.
 
- - Function: x:create-colormap WINDOW VISUAL ALLOC-POLICY
+ - Function: x:create-colormap window visual alloc-policy
      WINDOW specifies the window on whose screen you want to create a
      colormap.  VISUAL specifies a visual type supported on the screen.
      ALLOC-POLICY Specifies the colormap entries to be allocated.  You
@@ -1150,12 +1299,16 @@ A "colormap" maps pixel values to "RGB" color space values.
      Note that WINDOW is used only to determine the screen.
 
     `X:Gray-Scale'
+
     `X:Pseudo-Color'
+
     `X:Direct-Color'
           The initial values of the colormap entries are undefined.
 
     `X:Static-Gray'
+
     `X:Static-Color'
+
     `X:True-Color'
           The entries have defined values, but those values are
           specific to VISUAL and are not defined by X.  The
@@ -1170,6 +1323,7 @@ A "colormap" maps pixel values to "RGB" color space values.
      undefined.
 
     `X:Gray-Scale'
+
     `X:Pseudo-Color'
           The effect is as if an `XAllocColorCells' call returned all
           pixel values from zero to N - 1, where N is the colormap
@@ -1185,7 +1339,7 @@ A "colormap" maps pixel values to "RGB" color space values.
 To create a new colormap when the allocation out of a previously shared
 colormap has failed because of resource exhaustion, use:
 
- - Function: x:copy-colormap-and-free COLORMAP
+ - Function: x:copy-colormap-and-free colormap
      Creates and returns a colormap of the same visual type and for the
      same screen as the specified COLORMAP.  It also moves all of the
      client's existing allocation from the specified COLORMAP to the
@@ -1207,8 +1361,8 @@ A "colormap" maps pixel values to elements of the "RGB" datatype.  An
 RGB is a list or vector of 3 integers, describing the red, green, and
 blue intensities respectively.  The integers are in the range 0 - 65535.
 
- - Function: x:alloc-colormap-cells COLORMAP NCOLORS NPLANES
- - Function: x:alloc-colormap-cells COLORMAP NCOLORS NPLANES CONTIGUOUS?
+ - Function: x:alloc-colormap-cells colormap ncolors nplanes
+ - Function: x:alloc-colormap-cells colormap ncolors nplanes contiguous?
      The `X:Alloc-Color-Cells' function allocates read/write color
      cells.  The number of colors, NCOLORS must be positive and the
      number of planes, NPLANES nonnegative.  If NCOLORS and nplanes are
@@ -1220,6 +1374,7 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      request.
 
     `x:Gray-Scale'
+
     `x:Pseudo-Color'
           Each mask has exactly one bit set to 1.  If CONTIGUOUS? is
           non-false and if all masks are ORed together, a single
@@ -1236,8 +1391,8 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      succeeded or #f if it failed.  The first array has the pixels
      allocated and the second has the plane-masks.
 
- - Function: x:alloc-colormap-cells COLORMAP NCOLORS RGB
- - Function: x:alloc-colormap-cells COLORMAP NCOLORS RGB CONTIGUOUS?
+ - Function: x:alloc-colormap-cells colormap ncolors rgb
+ - Function: x:alloc-colormap-cells colormap ncolors rgb contiguous?
      The specified NCOLORS must be positive; and RGB a list or vector
      of 3 nonnegative integers.  If NCOLORS colors, NREDS reds, NGREENS
      greens, and NBLUES blues are requested, NCOLORS pixels are
@@ -1260,8 +1415,8 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      allocated.  The second, third, and fourth elements are the red,
      green, and blue plane-masks.
 
- - Function: x:free-colormap-cells COLORMAP PIXELS PLANES
- - Function: x:free-colormap-cells COLORMAP PIXELS
+ - Function: x:free-colormap-cells colormap pixels planes
+ - Function: x:free-colormap-cells colormap pixels
      Frees the cells represented by pixels whose values are in the
      PIXELS unsigned-integer uniform-vector.  The PLANES argument
      should not have any bits set to 1 in common with any of the
@@ -1284,12 +1439,12 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      passing `x:Alloc-All' to `X:Create-Colormap').  If more than one
      pixel is in error, the one that gets reported is arbitrary.
 
- - Function: x:colormap-find-color COLORMAP RGB
+ - Function: x:colormap-find-color colormap rgb
      RGB is a list or vector of 3 integers, describing the red, green,
      and blue intensities respectively; or an integer `#xrrggbb',
      packing red, green and blue intensities in the range 0 - 255.
 
- - Function: x:colormap-find-color COLORMAP COLOR-NAME
+ - Function: x:colormap-find-color colormap color-name
      The case-insensitive string COLOR_NAME specifies the name of a
      color (for example, `red')
 
@@ -1306,19 +1461,19 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      deallocated.
 
 
- - Function: x:color-ref COLORMAP PIXEL
+ - Function: x:color-ref colormap pixel
      Returns a list of 3 integers, describing the red, green, and blue
      intensities respectively of the COLORMAP entry of the cell indexed
      by PIXEL.
 
      The integer PIXEL must be a valid index into COLORMAP.
 
- - Function: X:Color-Set! COLORMAP PIXEL RGB
+ - Function: X:Color-Set! colormap pixel rgb
      RGB is a list or vector of 3 integers, describing the red, green,
      and blue intensities respectively; or an integer `#xrrggbb',
      packing red, green and blue intensities in the range 0 - 255.
 
- - Function: X:Color-Set! COLORMAP PIXEL COLOR-NAME
+ - Function: X:Color-Set! colormap pixel color-name
      The case-insensitive string COLOR_NAME specifies the name of a
      color (for example, `red')
 
@@ -1329,7 +1484,7 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      screen, the changes are visible immediately.
 
 
- - Function: x:install-colormap COLORMAP
+ - Function: x:install-colormap colormap
      Installs the specified COLORMAP for its associated screen.  All
      windows associated with COLORMAP immediately display with true
      colors.  A colormap is associated with a window when the window is
@@ -1340,21 +1495,24 @@ blue intensities respectively.  The integers are in the range 0 - 65535.
      has that colormap.
 
 
+ - Function: x:ccc colormap
+     Returns the Color-Conversion-Context of COLORMAP.
+
 
-File: Xlibscm.info,  Node: Rendering,  Next: Event,  Prev: Colormap,  Up: Top
+File: Xlibscm.info,  Node: Rendering,  Next: Images,  Prev: Colormap,  Up: Top
 
 Rendering
 *********
 
- - Function: x:flush DISPLAY
- - Function: x:flush WINDOW
+ - Function: x:flush display
+ - Function: x:flush window
      Flushes the output buffer.  Some client applications need not use
      this function because the output buffer is automatically flushed
      as needed by calls to X:Pending, X:Next-Event, and X:Window-Event.
      Events generated by the server may be enqueued into the library's
      event queue.
 
- - Function: x:flush GC
+ - Function: x:flush gc
      Forces sending of GC component changes.
 
      Xlib usually defers sending changes to the components of a GC to
@@ -1366,7 +1524,7 @@ Rendering
      the GC indirectly, in such a way that the extension interface
      cannot know what GC will be used.
 
- - Function: x:clear-area WINDOW (X-POS Y-POS) (WIDTH HEIGHT) EXPOSE?
+ - Function: x:clear-area window (x-pos y-pos) (width height) expose?
      Paints a rectangular area in the specified WINDOW according to the
      specified dimensions with the WINDOW's background pixel or pixmap.
      The subwindow-mode effectively is `x:Clip-By-Children'.  If width
@@ -1380,35 +1538,35 @@ Rendering
      are either visible or are being retained in a backing store.  If
      you specify a WINDOW whose class is x:Input-Only, an error results.
 
- - Function: x:fill-rectangle WINDOW GCONTEXT POSITION SIZE
+ - Function: x:fill-rectangle window gcontext position size
 
 Draw Strings
 ============
 
- - Function: x:draw-string DRAWABLE GC POSITION STRING
+ - Function: x:draw-string drawable gc position string
      POSITION specifies coordinates relative to the origin of DRAWABLE
      of the origin of the first character to be drawn.
 
      `x:draw-string' draws the characters of STRING, starting at
      POSITION.
 
- - Function: x:image-string DRAWABLE GC POSITION STRING
+ - Function: x:image-string drawable gc position string
      POSITION specifies coordinates relative to the origin of DRAWABLE
      of the origin of the first character to be drawn.
 
-     `x:image-string' draws the characters *and background* of STRING,
+     `x:image-string' draws the characters _and background_ of STRING,
      starting at POSITION.
 
 Draw Shapes
 ===========
 
- - Function: x:draw-points DRAWABLE GC POSITION ...
+ - Function: x:draw-points drawable gc position ...
      POSITION ... specifies coordinates of the point to be drawn.
 
- - Function: x:draw-points DRAWABLE GC X Y ...
+ - Function: x:draw-points drawable gc x y ...
      (X, Y) ... specifies coordinates of the point to be drawn.
 
- - Function: x:draw-points DRAWABLE GC POINT-ARRAY
+ - Function: x:draw-points drawable gc point-array
      POINT-ARRAY is a uniform short array of rank 2, whose rightmost
      index spans a range of 2.
 
@@ -1420,14 +1578,14 @@ Draw Shapes
      foreground, subwindow-mode, clip-x-origin, clip-y-origin, and
      clip-mask.
 
- - Function: x:draw-segments DRAWABLE GC POS1 POS2 ...
+ - Function: x:draw-segments drawable gc pos1 pos2 ...
      POS1, POS2, ... specify coordinates to be connected by segments.
 
- - Function: x:draw-segments DRAWABLE GC X1 Y1 X2 Y2 ...
+ - Function: x:draw-segments drawable gc x1 y1 x2 y2 ...
      (X1, Y1), (X2, Y2) ... specify coordinates to be connected by
      segments.
 
- - Function: x:draw-segments DRAWABLE GC POINT-ARRAY
+ - Function: x:draw-segments drawable gc point-array
      POINT-ARRAY is a uniform short array of rank 2, whose rightmost
      index spans a range of 2.
 
@@ -1450,14 +1608,14 @@ Draw Shapes
      tile, stipple, tilestipple-x-origin, tile-stipple-y-origin,
      dash-offset, and dash-list.
 
- - Function: x:draw-lines DRAWABLE GC POS1 POS2 ...
+ - Function: x:draw-lines drawable gc pos1 pos2 ...
      POS1, POS2, ... specify coordinates to be connected by lines.
 
- - Function: x:draw-lines DRAWABLE GC X1 Y1 X2 Y2 ...
+ - Function: x:draw-lines drawable gc x1 y1 x2 y2 ...
      (X1, Y1), (X2, Y2) ... specify coordinates to be connected by
      lines.
 
- - Function: x:draw-lines DRAWABLE GC POINT-ARRAY
+ - Function: x:draw-lines drawable gc point-array
      POINT-ARRAY is a uniform short array of rank 2, whose rightmost
      index spans a range of 2.
 
@@ -1481,13 +1639,13 @@ Draw Shapes
      tile, stipple, tilestipple-x-origin, tile-stipple-y-origin,
      dash-offset, and dash-list.
 
- - Function: x:fill-polygon DRAWABLE GC POS1 POS2 ...
+ - Function: x:fill-polygon drawable gc pos1 pos2 ...
      POS1, POS2, ... specify coordinates of the border path.
 
- - Function: x:fill-polygon DRAWABLE GC X1 Y1 X2 Y2 ...
+ - Function: x:fill-polygon drawable gc x1 y1 x2 y2 ...
      (X1, Y1), (X2, Y2) ... specify coordinates of the border path.
 
- - Function: x:fill-polygon DRAWABLE GC POINT-ARRAY
+ - Function: x:fill-polygon drawable gc point-array
      POINT-ARRAY is a uniform short array of rank 2, whose rightmost
      index spans a range of 2.
 
@@ -1507,7 +1665,15 @@ Draw Shapes
      tile-stipple-x-origin, and tile-stipple-y-origin.
 
 
-File: Xlibscm.info,  Node: Event,  Next: Index,  Prev: Rendering,  Up: Top
+File: Xlibscm.info,  Node: Images,  Next: Event,  Prev: Rendering,  Up: Top
+
+Images
+******
+
+ - Function: x:read-bitmap-file drawable file
+
+
+File: Xlibscm.info,  Node: Event,  Next: Index,  Prev: Images,  Up: Top
 
 Event
 *****
@@ -1515,16 +1681,16 @@ Event
 These three status routines always return immediately if there are
 events already in the queue.
 
- - Function: x:q-length DISPLAY
+ - Function: x:q-length display
      Returns the length of the event queue for the connected DISPLAY.
      Note that there may be more events that have not been read into the
      queue yet (see X:Events-Queued).
 
- - Function: x:pending DISPLAY
+ - Function: x:pending display
      Returns the number of events that have been received from the X
      server but have not been removed from the event queue.
 
- - Function: x:events-queued DISPLAY
+ - Function: x:events-queued display
      Returns the number of events already in the queue if the number is
      nonzero.  If there are no events in the queue, `X:Events-Queued'
      attempts to read more events out of the application's connection
@@ -1532,12 +1698,12 @@ events already in the queue.
 
 Both of these routines return an object of type "event".
 
- - Function: x:next-event DISPLAY
+ - Function: x:next-event display
      Removes and returns the first event from the event queue.  If the
      event queue is empty, `X:Next-Event' flushes the output buffer and
      blocks until an event is received.
 
- - Function: x:peek-event DISPLAY
+ - Function: x:peek-event display
      Returns the first event from the event queue, but it does not
      remove the event from the queue.  If the queue is empty,
      `X:Peek-Event' flushes the output buffer and blocks until an event
@@ -1545,206 +1711,206 @@ Both of these routines return an object of type "event".
 
 Each event object has fields dependent on its sub-type.
 
- - Function: x:event-ref EVENT FIELD-NAME
-     window                      The window on which EVENT was generated  
-                                 and is referred to as the event window.  
-     root                        is the event window's root window.       
-     subwindow                   If the source window is an inferior of   
-                                 the event window, the SUBWINDOW is the   
-                                 child of the event window that is the    
-                                 source window or the child of the event  
-                                 window that is an ancestor of the        
-                                 source window.  Otherwise, `None'.       
-     X-event:type                An integer: X:KEY-PRESS, X:KEY-RELEASE,  
-                                 X:BUTTON-PRESS, X:BUTTON-RELEASE,        
-                                 X:MOTION-NOTIFY, X:ENTER-NOTIFY,         
-                                 X:LEAVE-NOTIFY, X:FOCUS-IN,              
-                                 X:FOCUS-OUT, X:KEYMAP-NOTIFY, X:EXPOSE,  
-                                 X:GRAPHICS-EXPOSE, X:NO-EXPOSE,          
-                                 X:VISIBILITY-NOTIFY, X:CREATE-NOTIFY,    
-                                 X:DESTROY-NOTIFY, X:UNMAP-NOTIFY,        
-                                 X:MAP-NOTIFY, X:MAP-REQUEST,             
-                                 X:REPARENT-NOTIFY, X:CONFIGURE-NOTIFY,   
-                                 X:CONFIGURE-REQUEST, X:GRAVITY-NOTIFY,   
-                                 X:RESIZE-REQUEST, X:CIRCULATE-NOTIFY,    
-                                 X:CIRCULATE-REQUEST, X:PROPERTY-NOTIFY,  
-                                 X:SELECTION-CLEAR, X:SELECTION-REQUEST,  
-                                 X:SELECTION-NOTIFY, X:COLORMAP-NOTIFY,   
-                                 X:CLIENT-MESSAGE, or X:MAPPING-NOTIFY.   
-     X-event:serial              The serial number of the protocol        
-                                 request that generated the EVENT.        
-     X-event:send-event          Boolean that indicates whether the       
-                                 event was sent by a different client.    
-     X-event:time                The time when the EVENT was generated    
-                                 expressed in milliseconds.               
-     X-event:x                                                            
-     X-event:y                   For window entry/exit events the X and   
-                                 Y members are set to the coordinates of  
-                                 the pointer position in the event        
-                                 window.  This position is always the     
-                                 pointer's final position, not its        
-                                 initial position.  If the event window   
-                                 is on the same screen as the root        
-                                 window, X and Y are the pointer          
-                                 coordinates relative to the event        
-                                 window's origin.  Otherwise, X and Y     
-                                 are set to zero.                         
-                                                                          
-                                 For expose events The X and Y members    
-                                 are set to the coordinates relative to   
-                                 the drawable's origin and indicate the   
-                                 upper-left corner of the rectangle.      
-                                                                          
-                                 For configure, create, gravity, and      
-                                 reparent events the X and Y members are  
-                                 set to the window's coordinates          
-                                 relative to the parent window's origin   
-                                 and indicate the position of the         
-                                 upper-left outside corner of the         
-                                 created window.                          
-     X-event:x-root                                                       
-     X-event:y-root              The pointer's coordinates relative to    
-                                 the root window's origin at the time of  
-                                 the EVENT.                               
-     X-event:state               For keyboard, pointer and window         
-                                 entry/exit events, the state member is   
-                                 set to indicate the logical state of     
-                                 the pointer buttons and modifier keys    
-                                 just prior to the EVENT, which is the    
-                                 bitwise inclusive OR of one or more of   
-                                 the button or modifier key masks:        
-                                 X:BUTTON1-MASK, X:BUTTON2-MASK,          
-                                 X:BUTTON3-MASK, X:BUTTON4-MASK,          
-                                 X:BUTTON5-MASK, X:SHIFT-MASK,            
-                                 X:LOCK-MASK, X:CONTROL-MASK,             
-                                 X:MOD1-MASK, X:MOD2-MASK, X:MOD3-MASK,   
-                                 X:MOD4-MASK, and X:MOD5-MASK.            
-                                                                          
-                                 For visibility events, the state of the  
-                                 window's visibility:                     
-                                 X:VISIBILITY-UNOBSCURED,                 
-                                 X:VISIBILITY-PARTIALLY-OBSCURED, or      
-                                 X:VISIBILITY-FULLY-OBSCURED.             
-                                                                          
-                                 For colormap events, indicates whether   
-                                 the colormap is installed or             
-                                 uninstalled: x:Colormap-Installed or     
-                                 x:Colormap-Uninstalled.                  
-                                                                          
-                                 For property events, indicates whether   
-                                 the property was changed to a new value  
-                                 or deleted: x:Property-New-Value or      
-                                 x:Property-Delete.                       
-     X-event:keycode             An integer that represents a physical    
-                                 key on the keyboard.                     
-     X-event:same-screen         Indicates whether the event window is    
-                                 on the same screen as the root window.   
-                                 If #t, the event and root windows are    
-                                 on the same screen.  If #f, the event    
-                                 and root windows are not on the same     
-                                 screen.                                  
-     X-event:button              The pointer button that changed state;   
-                                 can be the X:BUTTON1, X:BUTTON2,         
-                                 X:BUTTON3, X:BUTTON4, or X:BUTTON5       
-                                 value.                                   
-     X-event:is-hint             Detail of motion-notify events:          
-                                 X:NOTIFY-NORMAL or X:NOTIFY-HINT.        
-     X-event:mode                Indicates whether the EVENT is a normal  
-                                 event, pseudo-motion event when a grab   
-                                 activates, or a pseudo-motion event      
-                                 when a grab deactivates:                 
-                                 X:NOTIFY-NORMAL, X:NOTIFY-GRAB, or       
-                                 X:NOTIFY-UNGRAB.                         
-     X-event:detail              Indicates the notification detail:       
-                                 X:NOTIFY-ANCESTOR, X:NOTIFY-VIRTUAL,     
-                                 X:NOTIFY-INFERIOR, X:NOTIFY-NONLINEAR,   
-                                 or X:NOTIFY-NONLINEAR-VIRTUAL.           
-     X-event:focus               If the event window is the focus window  
-                                 or an inferior of the focus window, #t;  
-                                 otherwise #f.                            
-     X-event:width                                                        
-     X-event:height              The size (extent) of the rectangle.      
-     X-event:count               For mapping events is the number of      
-                                 keycodes altered.                        
-                                                                          
-                                 For expose events Is the number of       
-                                 Expose or GraphicsExpose events that     
-                                 are to follow.  If count is zero, no     
-                                 more Expose events follow for this       
-                                 window.  However, if count is nonzero,   
-                                 at least that number of Expose events    
-                                 (and possibly more) follow for this      
-                                 window.  Simple applications that do     
-                                 not want to optimize redisplay by        
-                                 distinguishing between subareas of its   
-                                 window can just ignore all Expose        
-                                 events with nonzero counts and perform   
-                                 full redisplays on events with zero      
-                                 counts.                                  
-     X-event:major-code          The major_code member is set to the      
-                                 graphics request initiated by the        
-                                 client and can be either X_CopyArea or   
-                                 X_CopyPlane.  If it is X_CopyArea, a     
-                                 call to XCopyArea initiated the          
-                                 request.  If it is X_CopyPlane, a call   
-                                 to XCopyPlane initiated the request.     
-     X-event:minor-code          Not currently used.                      
-     X-event:border-width        For configure events, the width of the   
-                                 window's border, in pixels.              
-     X-event:override-redirect   The override-redirect attribute of the   
-                                 window.  Window manager clients          
-                                 normally should ignore this window if    
-                                 it is #t.                                
-     X-event:from-configure      True if the event was generated as a     
-                                 result of a resizing of the window's     
-                                 parent when the window itself had a      
-                                 win-gravity of x:Unmap-Gravity.          
-     X-event:value-mask          Indicates which components were          
-                                 specified in the ConfigureWindow         
-                                 protocol request.  The corresponding     
-                                 values are reported as given in the      
-                                 request.  The remaining values are       
-                                 filled in from the current geometry of   
-                                 the window, except in the case of above  
-                                 (sibling) and detail (stack-mode),       
-                                 which are reported as None and Above,    
-                                 respectively, if they are not given in   
-                                 the request.                             
-     X-event:place               The window's position after the restack  
-                                 occurs and is either x:Place-On-Top or   
-                                 x:Place-On-Bottom.  If it is             
-                                 x:Place-On-Top, the window is now on     
-                                 top of all siblings.  If it is           
-                                 x:Place-On-Bottom, the window is now     
-                                 below all siblings.                      
-     X-event:new                 indicate whether the colormap for the    
-                                 specified window was changed or          
-                                 installed or uninstalled and can be      
-                                 True or False.  If it is True, the       
-                                 colormap was changed.  If it is False,   
-                                 the colormap was installed or            
-                                 uninstalled.                             
-     X-event:format              Is 8, 16, or 32 and specifies whether    
-                                 the data should be viewed as a list of   
-                                 bytes, shorts, or longs                  
-     X-event:request             Indicates the kind of mapping change     
-                                 that occurred and can be                 
-                                 X:MAPPING-MODIFIER, X:MAPPING-KEYBOARD,  
-                                 or X:MAPPING-POINTER.  If it is          
-                                 X:MAPPING-MODIFIER, the modifier         
-                                 mapping was changed.  If it is           
-                                 X:MAPPING-KEYBOARD, the keyboard         
-                                 mapping was changed.  If it is           
-                                 X:MAPPING-POINTER, the pointer button    
-                                 mapping was changed.                     
-     X-event:first-keycode       The X-event:first-keycode is set only    
-                                 if the X-event:request was set to        
-                                 X:MAPPING-KEYBOARD.  The number in       
-                                 X-event:first-keycode represents the     
-                                 first number in the range of the         
-                                 altered mapping, and X-event:count       
-                                 represents the number of keycodes        
-                                 altered.                                 
+ - Function: x:event-ref event field-name
+     window                      The window on which EVENT was generated
+                                 and is referred to as the event window.
+     root                        is the event window's root window.
+     subwindow                   If the source window is an inferior of
+                                 the event window, the SUBWINDOW is the
+                                 child of the event window that is the
+                                 source window or the child of the event
+                                 window that is an ancestor of the
+                                 source window.  Otherwise, `None'.
+     X-event:type                An integer: X:KEY-PRESS, X:KEY-RELEASE,
+                                 X:BUTTON-PRESS, X:BUTTON-RELEASE,
+                                 X:MOTION-NOTIFY, X:ENTER-NOTIFY,
+                                 X:LEAVE-NOTIFY, X:FOCUS-IN,
+                                 X:FOCUS-OUT, X:KEYMAP-NOTIFY, X:EXPOSE,
+                                 X:GRAPHICS-EXPOSE, X:NO-EXPOSE,
+                                 X:VISIBILITY-NOTIFY, X:CREATE-NOTIFY,
+                                 X:DESTROY-NOTIFY, X:UNMAP-NOTIFY,
+                                 X:MAP-NOTIFY, X:MAP-REQUEST,
+                                 X:REPARENT-NOTIFY, X:CONFIGURE-NOTIFY,
+                                 X:CONFIGURE-REQUEST, X:GRAVITY-NOTIFY,
+                                 X:RESIZE-REQUEST, X:CIRCULATE-NOTIFY,
+                                 X:CIRCULATE-REQUEST, X:PROPERTY-NOTIFY,
+                                 X:SELECTION-CLEAR, X:SELECTION-REQUEST,
+                                 X:SELECTION-NOTIFY, X:COLORMAP-NOTIFY,
+                                 X:CLIENT-MESSAGE, or X:MAPPING-NOTIFY.
+     X-event:serial              The serial number of the protocol
+                                 request that generated the EVENT.
+     X-event:send-event          Boolean that indicates whether the
+                                 event was sent by a different client.
+     X-event:time                The time when the EVENT was generated
+                                 expressed in milliseconds.
+     X-event:x                   
+     X-event:y                   For window entry/exit events the X and
+                                 Y members are set to the coordinates of
+                                 the pointer position in the event
+                                 window.  This position is always the
+                                 pointer's final position, not its
+                                 initial position.  If the event window
+                                 is on the same screen as the root
+                                 window, X and Y are the pointer
+                                 coordinates relative to the event
+                                 window's origin.  Otherwise, X and Y
+                                 are set to zero.
+                                 
+                                 For expose events The X and Y members
+                                 are set to the coordinates relative to
+                                 the drawable's origin and indicate the
+                                 upper-left corner of the rectangle.
+                                 
+                                 For configure, create, gravity, and
+                                 reparent events the X and Y members are
+                                 set to the window's coordinates
+                                 relative to the parent window's origin
+                                 and indicate the position of the
+                                 upper-left outside corner of the
+                                 created window.
+     X-event:x-root              
+     X-event:y-root              The pointer's coordinates relative to
+                                 the root window's origin at the time of
+                                 the EVENT.
+     X-event:state               For keyboard, pointer and window
+                                 entry/exit events, the state member is
+                                 set to indicate the logical state of
+                                 the pointer buttons and modifier keys
+                                 just prior to the EVENT, which is the
+                                 bitwise inclusive OR of one or more of
+                                 the button or modifier key masks:
+                                 X:BUTTON1-MASK, X:BUTTON2-MASK,
+                                 X:BUTTON3-MASK, X:BUTTON4-MASK,
+                                 X:BUTTON5-MASK, X:SHIFT-MASK,
+                                 X:LOCK-MASK, X:CONTROL-MASK,
+                                 X:MOD1-MASK, X:MOD2-MASK, X:MOD3-MASK,
+                                 X:MOD4-MASK, and X:MOD5-MASK.
+                                 
+                                 For visibility events, the state of the
+                                 window's visibility:
+                                 X:VISIBILITY-UNOBSCURED,
+                                 X:VISIBILITY-PARTIALLY-OBSCURED, or
+                                 X:VISIBILITY-FULLY-OBSCURED.
+                                 
+                                 For colormap events, indicates whether
+                                 the colormap is installed or
+                                 uninstalled: x:Colormap-Installed or
+                                 x:Colormap-Uninstalled.
+                                 
+                                 For property events, indicates whether
+                                 the property was changed to a new value
+                                 or deleted: x:Property-New-Value or
+                                 x:Property-Delete.
+     X-event:keycode             An integer that represents a physical
+                                 key on the keyboard.
+     X-event:same-screen         Indicates whether the event window is
+                                 on the same screen as the root window.
+                                 If #t, the event and root windows are
+                                 on the same screen.  If #f, the event
+                                 and root windows are not on the same
+                                 screen.
+     X-event:button              The pointer button that changed state;
+                                 can be the X:BUTTON1, X:BUTTON2,
+                                 X:BUTTON3, X:BUTTON4, or X:BUTTON5
+                                 value.
+     X-event:is-hint             Detail of motion-notify events:
+                                 X:NOTIFY-NORMAL or X:NOTIFY-HINT.
+     X-event:mode                Indicates whether the EVENT is a normal
+                                 event, pseudo-motion event when a grab
+                                 activates, or a pseudo-motion event
+                                 when a grab deactivates:
+                                 X:NOTIFY-NORMAL, X:NOTIFY-GRAB, or
+                                 X:NOTIFY-UNGRAB.
+     X-event:detail              Indicates the notification detail:
+                                 X:NOTIFY-ANCESTOR, X:NOTIFY-VIRTUAL,
+                                 X:NOTIFY-INFERIOR, X:NOTIFY-NONLINEAR,
+                                 or X:NOTIFY-NONLINEAR-VIRTUAL.
+     X-event:focus               If the event window is the focus window
+                                 or an inferior of the focus window, #t;
+                                 otherwise #f.
+     X-event:width               
+     X-event:height              The size (extent) of the rectangle.
+     X-event:count               For mapping events is the number of
+                                 keycodes altered.
+                                 
+                                 For expose events Is the number of
+                                 Expose or GraphicsExpose events that
+                                 are to follow.  If count is zero, no
+                                 more Expose events follow for this
+                                 window.  However, if count is nonzero,
+                                 at least that number of Expose events
+                                 (and possibly more) follow for this
+                                 window.  Simple applications that do
+                                 not want to optimize redisplay by
+                                 distinguishing between subareas of its
+                                 window can just ignore all Expose
+                                 events with nonzero counts and perform
+                                 full redisplays on events with zero
+                                 counts.
+     X-event:major-code          The major_code member is set to the
+                                 graphics request initiated by the
+                                 client and can be either X_CopyArea or
+                                 X_CopyPlane.  If it is X_CopyArea, a
+                                 call to XCopyArea initiated the
+                                 request.  If it is X_CopyPlane, a call
+                                 to XCopyPlane initiated the request.
+     X-event:minor-code          Not currently used.
+     X-event:border-width        For configure events, the width of the
+                                 window's border, in pixels.
+     X-event:override-redirect   The override-redirect attribute of the
+                                 window.  Window manager clients
+                                 normally should ignore this window if
+                                 it is #t.
+     X-event:from-configure      True if the event was generated as a
+                                 result of a resizing of the window's
+                                 parent when the window itself had a
+                                 win-gravity of x:Unmap-Gravity.
+     X-event:value-mask          Indicates which components were
+                                 specified in the ConfigureWindow
+                                 protocol request.  The corresponding
+                                 values are reported as given in the
+                                 request.  The remaining values are
+                                 filled in from the current geometry of
+                                 the window, except in the case of above
+                                 (sibling) and detail (stack-mode),
+                                 which are reported as None and Above,
+                                 respectively, if they are not given in
+                                 the request.
+     X-event:place               The window's position after the restack
+                                 occurs and is either x:Place-On-Top or
+                                 x:Place-On-Bottom.  If it is
+                                 x:Place-On-Top, the window is now on
+                                 top of all siblings.  If it is
+                                 x:Place-On-Bottom, the window is now
+                                 below all siblings.
+     X-event:new                 indicate whether the colormap for the
+                                 specified window was changed or
+                                 installed or uninstalled and can be
+                                 True or False.  If it is True, the
+                                 colormap was changed.  If it is False,
+                                 the colormap was installed or
+                                 uninstalled.
+     X-event:format              Is 8, 16, or 32 and specifies whether
+                                 the data should be viewed as a list of
+                                 bytes, shorts, or longs
+     X-event:request             Indicates the kind of mapping change
+                                 that occurred and can be
+                                 X:MAPPING-MODIFIER, X:MAPPING-KEYBOARD,
+                                 or X:MAPPING-POINTER.  If it is
+                                 X:MAPPING-MODIFIER, the modifier
+                                 mapping was changed.  If it is
+                                 X:MAPPING-KEYBOARD, the keyboard
+                                 mapping was changed.  If it is
+                                 X:MAPPING-POINTER, the pointer button
+                                 mapping was changed.
+     X-event:first-keycode       The X-event:first-keycode is set only
+                                 if the X-event:request was set to
+                                 X:MAPPING-KEYBOARD.  The number in
+                                 X-event:first-keycode represents the
+                                 first number in the range of the
+                                 altered mapping, and X-event:count
+                                 represents the number of keycodes
+                                 altered.
 
 
 File: Xlibscm.info,  Node: Index,  Prev: Event,  Up: Top
@@ -1757,11 +1923,12 @@ Xlibscm.
 
 * Menu:
 
-* hostname:number.screen-number:         Display.
+* hostname:number.screen-number:         Display and Screens.
 * x:alloc-colormap-cells:                Colormap.
+* x:ccc:                                 Colormap.
 * x:clear-area:                          Rendering.
-* x:close <1>:                           Window.
-* x:close:                               Display.
+* x:close <1>:                           Windows and Pixmaps.
+* x:close:                               Display and Screens.
 * x:color-ref:                           Colormap.
 * X:Color-Set!:                          Colormap.
 * x:colormap-find-color:                 Colormap.
@@ -1770,13 +1937,13 @@ Xlibscm.
 * x:create-colormap:                     Colormap.
 * x:create-cursor:                       Cursor.
 * x:create-gc:                           Graphics Context.
-* x:create-pixmap:                       Window.
-* x:create-window:                       Window.
-* x:default-colormap:                    Screen.
-* x:default-depths:                      Screen.
-* x:default-gc:                          Screen.
-* x:default-screen:                      Screen.
-* x:default-visual:                      Screen.
+* x:create-pixmap:                       Windows and Pixmaps.
+* x:create-window:                       Windows and Pixmaps.
+* x:default-ccc:                         Display and Screens.
+* x:default-colormap:                    Display and Screens.
+* x:default-gc:                          Display and Screens.
+* x:default-screen:                      Display and Screens.
+* x:default-visual:                      Display and Screens.
 * x:draw-lines:                          Rendering.
 * x:draw-points:                         Rendering.
 * x:draw-segments:                       Rendering.
@@ -1789,32 +1956,39 @@ Xlibscm.
 * x:free-colormap-cells:                 Colormap.
 * x:gc-ref:                              Graphics Context.
 * x:gc-set!:                             Graphics Context.
+* x:get-window-property:                 Window Properties and Visibility.
 * x:image-string:                        Rendering.
 * x:install-colormap:                    Colormap.
-* x:make-visual:                         Screen.
-* x:map-raised:                          Window Visibility.
-* x:map-subwindows:                      Window Visibility.
-* x:map-window:                          Window Visibility.
+* x:list-properties:                     Window Properties and Visibility.
+* x:make-visual:                         Display and Screens.
+* x:map-subwindows:                      Window Properties and Visibility.
+* x:map-window:                          Window Properties and Visibility.
 * x:next-event:                          Event.
-* x:open-display:                        Display.
+* x:open-display:                        Display and Screens.
 * x:peek-event:                          Event.
 * x:pending:                             Event.
-* x:protocol-version:                    Display.
+* x:protocol-version:                    Display and Screens.
 * x:q-length:                            Event.
-* x:root-window:                         Screen.
-* x:screen-black:                        Screen.
-* x:screen-cells:                        Screen.
-* x:screen-count:                        Screen.
-* x:screen-depth:                        Screen.
-* x:screen-dimensions:                   Screen.
-* x:screen-size:                         Screen.
-* x:screen-white:                        Screen.
-* x:server-vendor:                       Display.
-* x:unmap-subwindows:                    Window Visibility.
-* x:unmap-window:                        Window Visibility.
-* x:vendor-release:                      Display.
-* x:window-geometry:                     Window.
-* x:window-set!:                         Window.
+* x:read-bitmap-file:                    Images.
+* x:root-window:                         Display and Screens.
+* x:screen-black:                        Display and Screens.
+* x:screen-cells:                        Display and Screens.
+* x:screen-count:                        Display and Screens.
+* x:screen-depth:                        Display and Screens.
+* x:screen-depths:                       Display and Screens.
+* x:screen-dimensions:                   Display and Screens.
+* x:screen-size:                         Display and Screens.
+* x:screen-white:                        Display and Screens.
+* x:server-vendor:                       Display and Screens.
+* x:unmap-subwindows:                    Window Properties and Visibility.
+* x:unmap-window:                        Window Properties and Visibility.
+* x:vendor-release:                      Display and Screens.
+* x:visual-class:                        Display and Screens.
+* x:visual-geometry:                     Display and Screens.
+* x:window-geometry:                     Windows and Pixmaps.
+* x:window-geometry-set!:                Windows and Pixmaps.
+* x:window-ref:                          Window Attributes.
+* x:window-set!:                         Window Attributes.
 
 Variable Index
 **************
@@ -1823,21 +1997,28 @@ This is an alphabetical list of all the global variables in Xlibscm.
 
 * Menu:
 
-* x:CW-Back-Pixel:                       Window.
-* x:CW-Back-Pixmap:                      Window.
-* x:CW-Backing-Pixel:                    Window.
-* x:CW-Backing-Planes:                   Window.
-* x:CW-Backing-Store:                    Window.
-* x:CW-Bit-Gravity:                      Window.
-* x:CW-Border-Pixel:                     Window.
-* x:CW-Border-Pixmap:                    Window.
-* x:CW-Colormap:                         Window.
-* x:CW-Cursor:                           Window.
-* x:CW-Dont-Propagate:                   Window.
-* x:CW-Event-Mask:                       Window.
-* x:CW-Override-Redirect:                Window.
-* x:CW-Save-Under:                       Window.
-* x:CW-Win-Gravity:                      Window.
+* x:CW-Back-Pixel:                       Window Attributes.
+* x:CW-Back-Pixmap:                      Window Attributes.
+* x:CW-Backing-Pixel:                    Window Attributes.
+* x:CW-Backing-Planes:                   Window Attributes.
+* x:CW-Backing-Store:                    Window Attributes.
+* x:CW-Bit-Gravity:                      Window Attributes.
+* x:CW-Border-Pixel:                     Window Attributes.
+* x:CW-Border-Pixmap:                    Window Attributes.
+* x:CW-Border-Width:                     Windows and Pixmaps.
+* x:CW-Colormap:                         Window Attributes.
+* x:CW-Cursor:                           Window Attributes.
+* x:CW-Dont-Propagate:                   Window Attributes.
+* x:CW-Event-Mask:                       Window Attributes.
+* x:CW-Height:                           Windows and Pixmaps.
+* x:CW-Override-Redirect:                Window Attributes.
+* x:CW-Save-Under:                       Window Attributes.
+* x:CW-Sibling:                          Windows and Pixmaps.
+* x:CW-Stack-Mode:                       Windows and Pixmaps.
+* x:CW-Width:                            Windows and Pixmaps.
+* x:CW-Win-Gravity:                      Window Attributes.
+* x:CWX:                                 Windows and Pixmaps.
+* x:CWY:                                 Windows and Pixmaps.
 * x:GC-Arc-Mode:                         Graphics Context.
 * x:GC-Background:                       Graphics Context.
 * x:GC-Cap-Style:                        Graphics Context.
@@ -1871,17 +2052,17 @@ Concept Index
 
 * colormap:                              Colormap.
 * cursor:                                Cursor.
-* depth:                                 Screen.
-* drawable:                              Window.
-* Drawable:                              Window.
-* map:                                   Window Visibility.
-* mapped:                                Window Visibility.
+* depth:                                 Display and Screens.
+* drawable:                              Drawables.
+* Drawable:                              Drawables.
+* map:                                   Window Properties and Visibility.
+* mapped:                                Window Properties and Visibility.
 * none:                                  Graphics Context.
 * RGB:                                   Colormap.
-* unmap:                                 Window Visibility.
-* unmapped:                              Window Visibility.
-* Visual:                                Screen.
-* visual:                                Screen.
+* unmap:                                 Window Properties and Visibility.
+* unmapped:                              Window Properties and Visibility.
+* Visual:                                Display and Screens.
+* visual:                                Display and Screens.
 * X:                                     Xlibscm.
 * x:None:                                Graphics Context.
 * Xlib:                                  Xlibscm.
@@ -1889,17 +2070,19 @@ Concept Index
 
 
 Tag Table:
-Node: Top241
-Node: Xlibscm1366
-Node: Display4144
-Node: Screen6776
-Node: Window10533
-Node: Window Visibility30412
-Node: Graphics Context34697
-Node: Cursor50412
-Node: Colormap52915
-Node: Rendering62691
-Node: Event70247
-Node: Index86684
+Node: Top215
+Node: Xlibscm1333
+Node: Display and Screens4123
+Node: Drawables11108
+Node: Windows and Pixmaps11369
+Node: Window Attributes18448
+Node: Window Properties and Visibility34428
+Node: Graphics Context38885
+Node: Cursor54592
+Node: Colormap57095
+Node: Rendering66961
+Node: Images74518
+Node: Event74659
+Node: Index89134
 
 End Tag Table
diff --git a/Xlibscm.texi b/Xlibscm.texi
index 59e6c3c..1d41a3c 100644
--- a/Xlibscm.texi
+++ b/Xlibscm.texi
@@ -82,20 +82,19 @@ by the author.
 @end ifinfo
 
 @menu
-* Xlibscm::
-* Display::
-* Screen::
-* Window::
-* Window Visibility::
-* Graphics Context::
-* Cursor::
-* Colormap::
-* Rendering::
-* Event::
-* Index::
+* Xlibscm::                     
+* Display and Screens::         
+* Drawables::                   
+* Graphics Context::            
+* Cursor::                      
+* Colormap::                    
+* Rendering::                   
+* Images::                      
+* Event::                       
+* Index::                       
 @end menu
 
-@node Xlibscm, Display, Top, Top
+@node Xlibscm, Display and Screens, Top, Top
 @chapter Xlibscm
 
 @dfn{Xlibscm} is a SCM interface to @dfn{X}.
@@ -188,8 +187,8 @@ the suitability of this documentation for any purpose.  It is provided
 ``as is'' without express or implied warranty.
 
 
-@node Display, Screen, Xlibscm, Top
-@chapter Display
+@node Display and Screens, Drawables, Xlibscm, Top
+@chapter Display and Screens
 
 @defun x:open-display display-name
 @var{display-name} Specifies the hardware display name, which determines
@@ -251,12 +250,8 @@ Returns a number related to a vendor's release of the X server.
 @end defun
 
 
-@node Screen, Window, Display, Top
-@chapter Screen
-
 A display consists of one or more @dfn{Screen}s.  Each screen has a
-@dfn{root-window}, @dfn{default-graphics-context}, @dfn{default-visual},
-and @dfn{colormap}.
+@dfn{root-window}, @dfn{default-graphics-context}, and @dfn{colormap}.
 
 @defun x:screen-count display
 Returns the number of available screens.
@@ -288,16 +283,23 @@ Returns the root window for the specified @var{window}'s screen.
 Returns the default colormap of the specified screen.
 @end defun
 
+@defun x:default-ccc display screen-number
+@defunx x:default-ccc display
+@defunx x:default-ccc window
+Returns the default Color-Conversion-Context (ccc) of the specified
+screen.
+@end defun
+
 @defun x:default-gc display screen-number
 @defunx x:default-gc display
 @defunx x:default-gc window
 Returns the default graphics-context of the specified screen.
 @end defun
 
-@defun x:default-depths display screen-number
-@defunx x:default-depths display
-@defunx x:default-depths window
-Returns a vector of depths supported by the specified screen.
+@defun x:screen-depths display screen-number
+@defunx x:screen-depths display
+@defunx x:screen-depths window
+Returns an array of depths supported by the specified screen.
 @end defun
 
 The @dfn{Visual} type describes possible colormap depths and
@@ -329,9 +331,27 @@ visual classes for a screen:
 
 @code{X:make-visual} returns a visual type for the screen specified by
 @var{display} or @var{window} if successful; #f if not.
+@end defun
 
+@defun x:visual-class visual
+@defunx x:visual-class screen
+@defunx x:visual-class display
+Returns the (integer) visual class of its argument.
+@end defun
+
+@defun x:visual-geometry visual
+@defunx x:visual-geometry screen
+@defunx x:visual-geometry display
+Returns a list of the:
+@itemize @bullet
+@item red_mask
+@item green_mask
+@item blue_mask
+@item colormap_size
+@end itemize
 @end defun
 
+
 @defun x:screen-cells display screen-number
 @defunx x:screen-cells display
 @defunx x:screen-cells window
@@ -339,9 +359,11 @@ Returns the number of entries in the default colormap.
 @end defun
 
 @defun x:screen-depth display screen-number
+Returns the depth of the root window of the specified screen.
 @defunx x:screen-depth display
 @defunx x:screen-depth window
-Returns the depth of the root window of the specified screen.
+@defunx x:screen-depth visual
+Returns the depth of argument.
 
 @cindex depth
 The @dfn{depth} of a window or pixmap is the number of bits per pixel it has.
@@ -373,14 +395,23 @@ Returns the white pixel value of the specified screen.
 Returns the black pixel value of the specified screen.
 @end defun
 
-
-@node Window, Window Visibility, Screen, Top
-@chapter Window
+@node Drawables, Graphics Context, Display and Screens, Top
+@chapter Drawables
 
 @cindex Drawable
 @cindex drawable
 A @dfn{Drawable} is either a window or pixmap.
 
+@menu
+* Windows and Pixmaps::         
+* Window Attributes::           
+* Window Properties and Visibility::  
+@end menu
+
+
+@node Windows and Pixmaps, Window Attributes, Drawables, Drawables
+@section Windows and Pixmaps
+
 @defun x:create-window window position size border-width depth class visual field-name value @dots{}
 Creates and returns an unmapped Input-Output subwindow for a specified
 parent @var{window} and causes the X server to generate a CreateNotify
@@ -447,12 +478,12 @@ Returns a list of:
 
 @table @asis
 @item coordinates
-@code{cons} of x and y coordinates that define the location of the
+@code{list} of x and y coordinates that define the location of the
 @var{drawable}.  For a window, these coordinates specify the upper-left
 outer corner relative to its parent's origin.  For pixmaps, these
 coordinates are always zero.
 @item size
-@code{cons} of the @var{drawable}'s dimensions (width and height).  For
+@code{list} of the @var{drawable}'s dimensions (width and height).  For
 a window, these dimensions specify the inside size, not including the
 border.
 @item border-width
@@ -463,6 +494,101 @@ The depth of the @var{drawable} (bits per pixel for the object).
 @end table
 @end defun
 
+
+@defun x:window-geometry-set! window field-name value @dots{}
+Changes the @dfn{Configuration} components specified by
+@var{field-name}s for the specified @var{window}.
+@end defun
+
+@noindent
+These are the attributes settable by @code{x:window-geometry-set!}.
+That these attributes are encoded by small integers -- just like those
+of the next section.  Be warned therefore that confusion of attribute
+names will likely not signal errors, just cause mysterious behavior.
+
+@defvr Attribute x:CWX
+@defvrx Attribute x:CWY
+@defvrx Attribute x:CW-Width
+@defvrx Attribute x:CW-Height
+The x:CWX and x:CYY members are used to set the window's x and y
+coordinates, which are relative to the parent's origin and indicate the
+position of the upper-left outer corner of the window.  The x:CW-Width
+and x:CW-Height members are used to set the inside size of the window,
+not including the border, and must be nonzero.  Attempts to configure a
+root window have no effect.
+
+If a window's size actually changes, the window's subwindows move
+according to their window gravity.  Depending on the window's bit
+gravity, the contents of the window also may be moved
+@end defvr
+
+@defvr Attribute x:CW-Border-Width
+The integer x:CW-Border-Width is used to set the width of the border in
+pixels.  Note that setting just the border width leaves the outer-left
+corner of the window in a fixed position but moves the absolute position
+of the window's origin.  It is an error to set the border-width
+attribute of an InputOnly window nonzero.
+@end defvr
+
+@defvr Attribute x:CW-Sibling
+The sibling member is used to set the sibling window for stacking
+operations.  
+@end defvr
+
+@defvr Attribute x:CW-Stack-Mode
+The x:CW-Stack-Mode member is used to set how the window is to be
+restacked and can be set to x:Above, x:Below, x:Top-If, x:Bottom-If, or
+x:Opposite.
+@end defvr
+
+@noindent
+If a sibling and a stack-mode are specified, the window is restacked as
+follows:
+
+@table @code
+@item x:Above
+The window is placed just above the sibling.
+@item x:Below
+The window is placed just below the sibling.
+@item x:Top-If
+If the sibling occludes the window, the window is placed at the top of
+the stack.
+@item x:Bottom-If
+If the window occludes the sibling, the window is placed at the bottom
+of the stack.
+@item x:Opposite
+If the sibling occludes the window, the window is placed at the top of
+the stack.  If the window occludes the sibling, the window is placed at
+the bottom of the stack.
+@end table
+
+@noindent
+If a stack-mode is specified but no sibling is specified, the window
+is restacked as follows:
+
+@table @code
+@item x:Above
+The window is placed at the top of the stack.
+@item x:Below
+The window is placed at the bottom of the stack.
+@item x:Top-If
+If any sibling occludes the window, the window is placed at the top of
+the stack.
+@item x:Bottom-If
+If the window occludes any sibling, the window is placed at the bottom
+of the stack.
+@item x:Opposite
+If any sibling occludes the window, the window is placed at the top of
+the stack.  If the window occludes any sibling, the window is placed at
+the bottom of the stack.
+@end table
+
+
+
+
+@node Window Attributes, Window Properties and Visibility, Windows and Pixmaps, Drawables
+@section Window Attributes
+
 @defun x:window-set! window field-name value @dots{}
 Changes the components specified by @var{field-name}s for the specified
 @var{window}.  The restrictions are the same as for
@@ -471,8 +597,6 @@ altered is server dependent.  If an error occurs, a subset of the
 components may have been altered.
 @end defun
 
-@heading Window Attributes
-
 @noindent
 The @code{x:create-window} and @code{x:window-set!} procedures take five
 and one argument (respectively) followed by pairs of arguments, where
@@ -773,9 +897,41 @@ in the parent's cursor will cause an immediate change in the displayed
 cursor.  On the root window, the default cursor is restored.
 @end defvr
 
+@defun x:window-ref window field-name @dots{}
+Returns a list of the components specified by @var{field-name}s for the
+specified @var{window}.  Allowable @var{field-name}s are a subset of
+those for @code{x:window-set!}:
+
+@itemize @bullet
+@item x:CW-Back-Pixel
+@item x:CW-Bit-Gravity
+@item x:CW-Win-Gravity
+@item x:CW-Backing-Store
+@item x:CW-Backing-Planes
+@item x:CW-Backing-Pixel
+@item x:CW-Override-Redirect
+@item x:CW-Save-Under
+@item x:CW-Event-Mask
+@item x:CW-Dont-Propagate
+@item x:CW-Colormap
+@end itemize
+@end defun
+
 
-@node Window Visibility, Graphics Context, Window, Top
-@chapter Window Visibility
+@node Window Properties and Visibility,  , Window Attributes, Drawables
+@section Window Properties and Visibility
+
+@defun x:get-window-property window property 
+Returns the (string or list of numbers) value of @var{property} of
+@var{window}.
+@defunx x:get-window-property window property #t
+Removes and returns the (string or list of numbers) value of
+@var{property} of @var{window}.
+@end defun
+
+@defun x:list-properties window
+Returns a list of the properties (strings) defined for @var{window}.
+@end defun
 
 @noindent
 In X parlance, a window which is hidden even when not obscured by other
@@ -824,13 +980,6 @@ leads to simpler programs and to proper interaction with window
 managers.
 @end defun
 
-@defun x:map-raised window
-This procedure is similar to @code{x:map-window} in that it maps the
-@var{window} and all of its subwindows that have had map requests.
-However, it also raises the specified @var{window} to the top of the
-stack.
-@end defun
-
 @defun x:map-subwindows window
 Maps all subwindows of a specified @var{window} in top-to-bottom
 stacking order.  The X server generates x:Expose events on each newly
@@ -859,7 +1008,7 @@ at a time because the server needs to perform much of the work only
 once, for all of the windows, rather than for each window.
 @end defun
 
-@node Graphics Context, Cursor, Window Visibility, Top
+@node Graphics Context, Cursor, Drawables, Top
 @chapter Graphics Context
 
 @noindent
@@ -1312,13 +1461,13 @@ resides.  Note that @var{window} is used only to determine the screen.
 
 @table @samp
 @item X:Gray-Scale
-@itemx X:Pseudo-Color
-@itemx X:Direct-Color
+@item X:Pseudo-Color
+@item X:Direct-Color
 The initial values of the colormap entries are undefined.
 
 @item X:Static-Gray
-@itemx X:Static-Color
-@itemx X:True-Color
+@item X:Static-Color
+@item X:True-Color
 The entries have defined values, but those values are specific to
 @var{visual} and are not defined by X.  The @var{alloc-policy} must be
 @samp{X:Alloc-None}.
@@ -1335,7 +1484,7 @@ undefined.
 
 @table @samp
 @item X:Gray-Scale
-@itemx X:Pseudo-Color
+@item X:Pseudo-Color
 The effect is as if an @code{XAllocColorCells} call returned all pixel
 values from zero to N - 1, where N is the colormap entries value in
 @var{visual}.
@@ -1390,7 +1539,7 @@ be produced.  All of these are allocated writable by the request.
 
 @table @samp
 @item x:Gray-Scale
-@itemx x:Pseudo-Color
+@item x:Pseudo-Color
 Each mask has exactly one bit set to 1.  If @var{contiguous?} is
 non-false and if all masks are ORed together, a single contiguous set of
 bits set to 1 is formed.
@@ -1523,8 +1672,12 @@ colormap.
 
 @end defun
 
+@defun x:ccc colormap
+Returns the Color-Conversion-Context of @var{colormap}.
+@end defun
+
 
-@node Rendering, Event, Colormap, Top
+@node Rendering, Images, Colormap, Top
 @chapter Rendering
 
 @defun x:flush display
@@ -1697,7 +1850,14 @@ components: foreground, background, tile, stipple,
 tile-stipple-x-origin, and tile-stipple-y-origin.
 @end defun
 
-@node Event, Index, Rendering, Top
+@node Images, Event, Rendering, Top
+@chapter Images
+
+@defun x:read-bitmap-file drawable file
+
+@end defun
+
+@node Event, Index, Images, Top
 @chapter Event
 
 @noindent
@@ -1799,7 +1959,7 @@ For configure, create, gravity, and reparent events the @var{x} and
 parent window's origin and indicate the position of the upper-left
 outside corner of the created window.
 @item X-event:x-root
-@itemx X-event:y-root
+@item X-event:y-root
 @tab
 The pointer's coordinates relative to the root window's origin at the
 time of the @var{event}.
@@ -1855,7 +2015,7 @@ Indicates the notification detail: @var{x:Notify-Ancestor},
 If the event window is the focus window or an inferior of the focus
 window, #t; otherwise #f.
 @item X-event:width
-@itemx X-event:height
+@item X-event:height
 @tab
 The size (extent) of the rectangle.
 @item X-event:count
diff --git a/bench.scm b/bench.scm
index 12d7f4b..2d1cc07 100644
--- a/bench.scm
+++ b/bench.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2001 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
@@ -41,7 +41,7 @@
 ;;;; "bench.scm", Scheme benchmark computing digits of pi.
 ;;; Author: Aubrey Jaffer.
 
-(require (in-vicinity (implementation-vicinity) "pi.scm"))
+(load (in-vicinity (implementation-vicinity) "pi.scm"))
 (require 'transcript)
 (define isqrt
   (cond ((provided? 'inexact) sqrt)
@@ -51,16 +51,17 @@
 	(else quotient)))
 (define around
   (cond ((provided? 'inexact)
-	 (lambda (x)
-	   (cond ((>= 3000 (abs x) 3) (inexact->exact (round x)))
+	 (lambda (x bnd)
+	   (cond ((>= 99999 (abs x) bnd) (inexact->exact (round x)))
+		 ((> (abs x) 99999) (round x))
 		 (else x))))
-	(else identity)))
+	(else (lambda (x bnd) x))))
 
 (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)))
+	internal-time-units-per-second)))
 
 (define (benchmark . arg)
   (define file
@@ -75,22 +76,21 @@
 	    (let* ((avg (i/ (apply + tl) (length tl)))
 		   (dev (isqrt (i/ (apply
 				    + (map (lambda (x) (* (- x avg) (- x avg)))
-						 tl))
+					   tl))
 				   (length tl)))))
 	      (and file (transcript-on file))
 	      (for-each display
-			(list digits " digits took " (around avg) " mSec +/- "
-			      (around dev) " mSec."))
+			(list digits " digits took " (around avg 99)
+			      " +/- " (around dev 3) ".ms"))
 	      (newline)
-	      (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits)))
+	      (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))
+		    (scaled-dev (i/ (* (i/ (* dev 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))
-				"%."))
+			  (list " That is about "
+				(around scaled-avg 99)
+				" +/- "
+				(around scaled-dev 3)
+				".ms/(kB)^2"))
 		(newline)
 		(and file (transcript-off)))
 	      ))))))
diff --git a/build b/build
index 1921d3c..cde6729 100755
--- a/build
+++ b/build
@@ -1,4 +1,4 @@
-#!/bin/sh
+#! /bin/sh
 :;exec scmlit -f $0 -e"(bi)" build $*
 
 (require (in-vicinity (program-vicinity) "build.scm"))
@@ -65,6 +65,7 @@ NOS/VE, Unicos, VMS, Unix and similar systems.
     (append-info-node scm-info "Problems Running" "README")
     (append-info-node scm-info "Testing" "README")))
 
+(define build:csv (make-command-server build '*commands*))
 (define (build-from-argv argv)
   (cond ((string? argv)
 	 (require 'read-command)
@@ -75,15 +76,15 @@ NOS/VE, Unicos, VMS, Unix and similar systems.
     (cond
      ((pair? argv)
       (set! *optind* (+ 1 *optind*))
-      ((make-command-server build '*commands*)
+      (build:csv
        command
        (lambda (comname comval options positions arities types
 			defaulters checks aliases)
 	 (let* ((params (getopt->parameter-list
 			 argc argv options arities types aliases))
-		(fparams (fill-empty-parameters defaulters params)))
+		(fparams (and params (fill-empty-parameters defaulters params))))
 	   (cond ((not (list? params))
-		  (slib:warn 'build-from-argv 'not-parameters? fparams)
+		  ;;(slib:warn 'build-from-argv 'not-parameters? fparams)
 		  #f)
 		 ((not (check-parameters checks fparams))
 		  (slib:warn 'build-from-argv 'check-parameters 'failed)
diff --git a/build.scm b/build.scm
index 4c4d88d..7f896d4 100644
--- a/build.scm
+++ b/build.scm
@@ -1,13 +1,13 @@
 ;;; "build.scm" Build database and program	-*-scheme-*-
-;;; Copyright (C) 1994-1999 Aubrey Jaffer.
+;;; Copyright (C) 1994-2002 Aubrey Jaffer.
 ;;; See the file `COPYING' for terms applying to this program.
 
 (require 'parameters)
-(require 'database-utilities)
+(require 'databases)
+(require 'database-commands)
 (set! OPEN_WRITE "w")			; Because MS-DOS scripts need ^M
 
-;;;(define build (create-database "buildscm.scm" 'alist-table))
-(define build (create-database #f 'alist-table))
+(define build (add-command-tables (create-database #f 'alist-table)))
 
 (require 'glob)
 (require 'batch)
@@ -73,7 +73,8 @@
      ("setjump.s"	Cray-asm	platform-specific	"provides setjump and longjump 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.")
+     ("Link.scm"	Scheme	required	"Dynamic link/loading.")
+     ("compile.scm"	Scheme	required	"Hobbit compilation to C.")
      ("Macro.scm"	Scheme	required	"Supports Syntax-Rules Macros.")
      ("scmfig.h"	c-header	required	"contains system dependent definitions.")
      ("patchlvl.h"	c-header	required	"patchlevel of this release.")
@@ -91,6 +92,7 @@
      ("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.")
+     ("debug.c" c-source	required	"debugging, printing code.")
      ("unif.c"	c-source	required	"uniform vectors.")
      ("rope.c"	c-source	required	"C interface functions.")
      ("ramap.c"	c-source	optional	"array mapping")
@@ -215,7 +217,7 @@
 #;Alias for ARRAYS
 (define-build-feature
  'array
- '((define "ARRAYS")))
+ '((features arrays)))
 
 #;array-map! and array-for-each (arrays must also be featured).
 (define-build-feature
@@ -298,7 +300,7 @@
 (define-build-feature
  'turtlegr
  '((c-file "turtlegr.c") (c-lib graphics) (features inexact)
-   (init "init_turtlegr")))
+   (compiled-init "init_turtlegr")))
 
 #;Interface to Xlib graphics routines.
 (define-build-feature
@@ -323,7 +325,7 @@
 #;Client connections to the mysql databases.
 (define-build-feature
  'mysql
- '((c-file "database.c") (c-lib mysql) (init "init_database")))
+ '((c-file "database.c") (c-lib mysql) (compiled-init "init_database")))
 
 #;String regular expression matching.
 (define-build-feature
@@ -447,12 +449,15 @@
      (irix		 mips	   irix	     gcc       ) ;gcc
      (linux		 i386	   linux     gcc       ) ;gcc
      (linux-aout	 i386	   linux     gcc       ) ;gcc
+     (darwin		 powerpc   unix      cc	       ) ;gcc
      (microsoft-c	 8086	   ms-dos    cl	       ) ;link
      (microsoft-c-nt	 i386	   ms-dos    cl	       ) ;link
      (microsoft-quick-c	 8086	   ms-dos    qcl       ) ;qlink
      (ms-dos		 8086	   ms-dos    cc	       ) ;link
+     (openbsd		 *unknown* unix	     gcc       ) ;gcc
      (os/2-cset		 i386	   os/2	     icc       ) ;link386
      (os/2-emx		 i386	   os/2	     gcc       ) ;gcc
+     (plan9-8		 i386	   plan9     8c        ) ;8l
      (svr4-gcc-sun-ld	 sparc	   sunos     gcc       ) ;ld
      (sunos		 sparc	   sunos     cc	       ) ;ld
      (svr4		 *unknown* unix	     cc	       ) ;ld
@@ -484,9 +489,10 @@
      (debug *unknown* "-g" "-g" #f () ())
      (socket *unknown* "" "" #f () ())
      (lib *unknown* "" "" #f () ("scmmain.c"))
-     (mysql *unknown* ""
-	    "-lmysqlclient" "/usr/lib/mysql/libmysqlclient.la" () ())
+     (mysql *unknown* "-I/usr/include/mysql" "-L/usr/lib/mysql -lmysqlclient"
+	    "/usr/lib/mysql/libmysqlclient.a" () ())
 
+     (m cygwin32 "" "" "" () ())
      (c cygwin32 "" "" "" () ())
      (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ())
      (c linux-aout "" "-lc" "/usr/lib/libc.sa" () ())
@@ -523,13 +529,16 @@
      (m atari-st-gcc "" "-lpml" #f () ())
      (m atari-st-turbo-c "" "" #f () ())
 
+     (c plan9-8 "" "" #f () ())
+     (m plan9-8 "" "" #f () ())
+
      (m sunos "" "-lm" #f () ())
      (dlll sunos "-DSUN_DL" "-ldl" #f () ())
      (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ())
      (dump sunos "" "" #f ("unexelf.c" "gmalloc.c") ())
 
      (m svr4-gcc-sun-ld "" "-lm" #f () ())
-     (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl" #f () ())
+     (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl -export-dynamic" #f () ())
      (nostart svr4-gcc-sun-ld "" "-e __start -nostartfiles" #f ("ecrt0.c") ())
      (dump svr4-gcc-sun-ld "" "" #f ("unexelf.c" "gmalloc.c") ())
      (socket svr4-gcc-sun-ld "" "-lsocket -lnsl" #f () ())
@@ -559,6 +568,7 @@
      (m Microsoft-C "" "" #f () ())
      (c Microsoft-C-nt "" "" #f () ("findexec.c"))
      (m Microsoft-C-nt "" "" #f () ())
+     (debug Microsoft-C-nt "-Zi" "/debug" #f () ())
      (c Microsoft-Quick-C "" "" #f () ("findexec.c"))
      (m Microsoft-Quick-C "" "" #f () ())
 
@@ -575,12 +585,20 @@
      (m highc "" "" #f () ())
      (windows highc "-Hwin" "-Hwin" #f () ())
 
+     (m darwin "" "" #f () ())
+     (c darwin "" "" #f () ())
+     (curses darwin "" "" #f () ())
+     (regex darwin "" "" #f () ())
+
      (m freebsd "" "-lm" #f () ())
+     (curses freebsd "" "-lncurses" "/usr/lib/libncurses.a" () ())
      (regex freebsd "" "-lgnuregex" "" () ())
      (editline freebsd "" "-lreadline" "" () ())
      (dlll freebsd "-DSUN_DL" "" "" () ())
      (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ())
      (dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c") ())
+     (m openbsd "" "-lm" #f () ())
+     (curses openbsd "" "-lcurses" "/usr/lib/libcurses.a" () ())
      ))
 
   '(compile-commands
@@ -673,12 +691,15 @@
 	   oexe))))
 (defcommand compile-c-files Microsoft-C-nt
   (lambda (files parms)
-    (and (batch:try-chopped-command parms
-				    "cl" "-c" "-nologo" "-O2"
-				    (include-spec "-I" parms)
-				    (c-includes parms)
-				    (c-flags parms)
-				    files)
+    (and (batch:try-chopped-command
+	  parms
+	  "cl" "-c" "-nologo"
+	  (if (memq 'stack-limit (parameter-list-ref parms 'features))
+	      "-Oityb1" "-Ox")
+	  (include-spec "-I" parms)
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
 	 (truncate-up-to (map c->obj files) #\\))))
 (defcommand link-c-program Microsoft-C-nt
   (lambda (oname objects libs parms)
@@ -880,19 +901,6 @@
 ;			       objects)
 ;			      (batch:rebuild-catalog parms)
 ;			      (string-append oname ".sl"))))
-(defcommand make-dll-archive sunos
-  (lambda (oname objects libs parms)
-    (and (batch:try-command
-	  parms
-	  "ld" "-assert" "pure-text" "-o"
-	  (string-append
-	   (car (parameter-list-ref parms 'implvic))
-	   oname ".so.1.0")
-	  objects)
-	 (batch:rebuild-catalog parms)
-	 (string-append
-	  (car (parameter-list-ref parms 'implvic))
-	  oname ".so.1.0"))))
 
 (defcommand compile-c-files linux-aout
   (lambda (files parms)
@@ -937,11 +945,9 @@
       "-fpic" "-c" (c-includes parms)
       (c-flags parms)
       files)
-     (let* ((platform (car (parameter-list-ref
-			    parms 'platform)))
+     (let* ((platform (car (parameter-list-ref parms 'platform)))
 	    (ld-opts
-	     (map (lambda (l)
-		    (build:lib-ld-flag l platform))
+	     (map (lambda (l) (build:lib-ld-flag l platform))
 		  (parameter-list-ref parms 'c-lib)))
 	    (results
 	     (map
@@ -968,8 +974,7 @@
 	     (car (parameter-list-ref parms 'implvic))
 	     oname ".so")
 	    objects
-	    (map (lambda (l)
-		   (build:lib-ld-flag l platform))
+	    (map (lambda (l) (build:lib-ld-flag l platform))
 		 (parameter-list-ref parms 'c-lib)))
 	   (batch:rebuild-catalog parms)
 	   (string-append
@@ -984,7 +989,7 @@
 	   (append objects libs)))
 	 oname)))
 
-(defcommand compile-c-files Unicos
+(defcommand compile-c-files unicos
   (lambda (files parms)
     (and (batch:try-chopped-command
 	  parms
@@ -1000,6 +1005,34 @@
 	  parms "cc" "setjump.o" "-o" oname objects libs)
 	 oname)))
 
+;; George Bronnikov <goga@rubinstein.mccme.ru> describes options for the
+;; PLAN9 native C compiler `8c':
+;;
+;; -F Enable type-checking of calls to print(2) and other
+;;    formatted print routines.
+;; -V By default, the compilers are non-standardly lax about
+;;    type equality between void* values and other pointers.
+;;    This flag requires ANSI C conformance.
+;; -w Print warning messages about unused variables etc. (It
+;;    does print a lot of them, indeed.)
+;; -p Invoke a standard ANSI C preprocessor before compiling
+;;    (instead of a rudimentary builtin one used by default).
+(defcommand compile-c-files plan9-8
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "8c" "-Fwp" "-DPLAN9"		;"-V"
+	  ;;(include-spec "-i" parms)
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (truncate-up-to (map c->8 files) #\/))))
+(defcommand link-c-program plan9-8
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms "8l" "-o" oname objects libs)
+	 oname)))
+
 (defcommand compile-c-files gcc
   (lambda (files parms)
     (and (batch:try-chopped-command parms
@@ -1029,6 +1062,19 @@
 				    (c-flags parms)
 				    files)
 	 (truncate-up-to (map c->o files) "\\/]"))))
+(defcommand make-dll-archive gcc
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms
+	  "ld" "-assert" "pure-text" "-o"
+	  (string-append
+	   (car (parameter-list-ref parms 'implvic))
+	   oname ".so.1.0")
+	  objects)
+	 (batch:rebuild-catalog parms)
+	 (string-append
+	  (car (parameter-list-ref parms 'implvic))
+	  oname ".so.1.0"))))
 
 (defcommand compile-c-files cygwin32
   (lambda (files parms)
@@ -1074,6 +1120,33 @@
 			       "/usr/lib/crt0.o")
 			     (append objects libs)))
 	 oname)))
+(defcommand compile-dll-c-files svr4-gcc-sun-ld
+  (lambda (files parms)
+    (and
+     (batch:try-chopped-command
+      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)))
+	    (results
+	     (map
+	      (lambda (fname)
+		(and (batch:try-command
+		      parms
+		      "ld" "-G" "-o"
+		      (string-append fname ".so")
+		      (string-append fname ".o")
+		      ld-opts)
+		     (batch:delete-file
+		      parms (string-append fname ".o"))
+		     (string-append fname ".so")))
+	      (truncate-up-to (map c-> files) #\/))))
+       (and (apply and? results) results)))))
 
 (defcommand compile-c-files svr4
   (lambda (files parms)
@@ -1397,6 +1470,79 @@
 	  (car (parameter-list-ref parms 'implvic))
 	  oname ".so"))))
 
+(defcommand compile-c-files darwin
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O3" "-c"
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (map c->o files))))
+(defcommand link-c-program darwin
+  (lambda (oname objects libs parms)
+    (batch:rename-file parms
+		       oname (string-append oname "~"))
+    (and (batch:try-command parms
+			    "cc" "-o" oname
+			    (append objects libs))
+	 oname)))
+
+(defcommand compile-c-files openbsd
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O2" "-Wall" "-c"
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (map c->o files))))
+(defcommand link-c-program openbsd
+  (lambda (oname objects libs parms)
+    (batch:rename-file parms
+		       oname (string-append oname "~"))
+    (and (batch:try-command parms
+			    "cc" "-o" oname
+			    (must-be-first
+			     '("-nostartfiles"
+			       "pre-crt0.o" "crt0.o"
+			       "/usr/lib/crt0.o")
+			     (append libs objects)))
+	 oname)))
+(defcommand compile-dll-c-files openbsd
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O2" "-Wall" "-fPIC" "-c"
+	  (string-append
+	   "-I" (parameter-list-ref parms 'scm-srcdir))
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (let ((objs (map c->o files)))
+	   (every
+	    (lambda (f)
+	      (and (batch:try-command
+		    parms "gcc" "-shared" "-fPIC" f)
+		   (batch:try-command
+		    parms "mv" "a.out" f)))
+	    objs)
+	   objs))))
+
+(defcommand make-dll-archive openbsd
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms
+	  "gcc" "-shared" "-fPIC" "-o"
+	  (string-append
+	   (car (parameter-list-ref parms 'implvic))
+	   oname ".so")
+	  objects)
+	 (batch:rebuild-catalog parms)
+	 (string-append
+	  (car (parameter-list-ref parms 'implvic))
+	  oname ".so"))))
+
 (for-each (build 'add-domain)
 	  '((C-libraries C-libraries #f symbol #f)))
 
@@ -1406,7 +1552,7 @@
     *parameter-columns*
     *parameter-columns*
     ((1 platform single platform
-	(lambda (pl) (list batch:platform))
+	(lambda (pl) (list *operating-system*))
 	#f
 	"what to build it for")
      (2 target-name single string (lambda (pl) '("scm")) #f
@@ -1446,12 +1592,9 @@
      (16 scm-srcdir single filename
 	 (lambda (pl) (list (user-vicinity))) #f
 	 "directory path for files in the manifest")
-     (17 scm-libdir single filename
-	 (lambda (pl) (list (implementation-vicinity))) #f
-	 "directory path for files in the manifest")
-     (18 c-defines nary expression #f #f "#defines for C")
-     (19 c-includes nary expression #f #f "library induced defines for C")
-     (20 batch-port nary expression #f #f
+     (17 c-defines nary expression #f #f "#defines for C")
+     (18 c-includes nary expression #f #f "library induced defines for C")
+     (19 batch-port nary expression #f #f
 	 "port batch file will be written to.")
      ))
   '(build-pnames
@@ -1473,7 +1616,6 @@
      ("compiler options" 14)
      ("linker options" 15)
      ("scm srcdir" 16)
-     ("scm libdir" 17)
      ))
 
   '(*commands*
@@ -1493,9 +1635,6 @@
       #f
       "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)
@@ -1503,6 +1642,7 @@
 (define build:c-lib-support #f)
 (define build:c-suppress #f)
 (define plan-command #f)
+(define platform->os #f)
 
 ;;; Look up command on a platform, but default to '*unknown* if not
 ;;; initially found.
@@ -1588,10 +1728,15 @@
 	    parms (cons 'batch-dialect (list (os->batch-dialect os)))))))
 
       (adjoin-parameters!
-       parms
-       (cons 'c-defines c-defines)
-       (cons 'c-includes c-includes))
-
+	     parms
+	     (cons 'c-defines c-defines)
+	     (cons 'c-includes c-includes))
+      (set! parms
+	    (cons
+	     (cons 'operating-system
+		   (map platform->os (parameter-list-ref parms 'platform)))
+	     parms))
+      
       (let ((name (parameter-list-ref parms 'who)))
 	(set! name (if (null? name) (current-output-port) (car name)))
 	(batch:call-with-output-script
@@ -1678,6 +1823,7 @@
 
 (define c-> (filename:substitute?? "*.c" "*"))
 (define c->o (filename:substitute?? "*.c" "*.o"))
+(define c->8 (filename:substitute?? "*.c" "*.8"))
 (define c->obj (filename:substitute?? "*.c" "*.obj"))
 (define obj-> (filename:substitute?? "*.obj" "*"))
 (define obj->exe (filename:substitute?? "*.obj" "*.exe"))
@@ -1701,6 +1847,46 @@
 				  "slibcat"))
   #t)
 
+(define (logger . args)
+  (define cep (current-error-port))
+  (cond ((provided? 'bignum)
+	 (require 'posix-time)
+	 (let ((ct (ctime (current-time))))
+	   (string-set! ct (+ -1 (string-length ct)) #\:)
+	   (for-each (lambda (x) (display x cep))
+		     (cons ct (cons #\  args)))))
+	(else (for-each (lambda (x) (display x cep)) args)))
+  (newline cep))
+
+(define build:qacs #f)
+(define (build:serve request-line query-string header)
+  (define query-alist (and query-string (uri:decode-query query-string)))
+  (if (not build:qacs)
+      (set! build:qacs (make-query-alist-command-server build '*commands* #t)))
+  (call-with-outputs
+   (lambda () (build:qacs query-alist))
+   (lambda (stdout stderr . status)
+     (cond ((or (substring? ": ERROR: " stderr)
+		(substring? ": WARN: " stderr))
+	    => (lambda (idx)
+		 (set! stderr (substring stderr (+ 2 idx)
+					 (string-length stderr))))))
+     (cond ((null? status)
+	    (logger "Aborting query")
+	    (pretty-print query-alist)
+	    (display stderr)
+	    (list "buildscm Abort" (html:pre stdout)
+		  "<B>" (html:pre stderr) "</B>"))
+	   (else
+	    (display stderr)		;query is already logged
+	    (if (car status)
+		(http:content '(("Content-Type" . "text/plain")) ;application/x-sh
+			      stdout)
+		(list "buildscm Error" "<B>" (html:pre stderr) "</B>"
+		      "<HR>"
+		      (html:pre stdout))))))))
+;;; (print 'request-line '= (cgi:request-line)) (print 'header '=) (for-each print (cgi:query-header))
+
 (define build:initializer
   (lambda (rdb)
     (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f))
@@ -1716,10 +1902,13 @@
     (set! build:c-suppress
 	  (make-defaulting-platform-lookup
 	   (build:c-libraries 'get 'suppress-files)))
+    (set! platform->os (((rdb 'open-table) 'platform #f)
+			'get 'operating-system))
     (set! plan-command
 	  (let ((lookup (make-defaulting-platform-lookup
 			 (((rdb 'open-table) 'compile-commands #f)
 			  'get 'procedure))))
 	    (lambda (thing plat)
+	      ;;(print 'thing thing 'plat plat)
 	      (slib:eval (lookup thing plat)))))))
 (build:initializer build)
diff --git a/compile.scm b/compile.scm
new file mode 100755
index 0000000..ce96822
--- /dev/null
+++ b/compile.scm
@@ -0,0 +1,112 @@
+#! /bin/sh
+:;exec scm -e"(set! *script* \"$0\")" -f$0 $*
+
+;; Copyright (C) 1992-2002 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, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+;;
+;; As a special exception, the Free Software Foundation gives permission
+;; for additional uses of the text contained in its release of SCM.
+;;
+;; The exception is that, if you link the SCM 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 SCM 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 SCM.  If you copy
+;; code from other Free Software Foundation releases into a copy of
+;; SCM, 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 SCM, it is your choice
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "compile.scm", Compile C ==> Scheme ==> object-file.
+;;; Author: Aubrey Jaffer.
+
+(define (go-script)
+  (cond ((not *script*))
+	((and (<= 1 (- (length *argv*) *optind*))
+	      (not (eqv? #\- (string-ref (car (list-tail *argv* *optind*)) 0))))
+	 (apply compile-file (list-tail *argv* *optind*)))
+	(else
+	 (display "\
+\
+Usage: compile.scm FILE1.scm FILE2.scm ...
+\
+  Compiles Scheme FILE1.scm FILE2.scm ... to an object file named
+  FILE1<object-suffix>, where <object-suffix> is the object file suffix
+  for your computer (for instance, `.o').  FILE1.scm must be in the
+  current directory; FILE2.scm ... can be in other directories.
+"
+		  (current-error-port))
+	 (exit #f))))
+
+;;; This unusual autoload loads either the
+;;; source or compiled version if present.
+(if (not (defined? hobbit))		;Autoload for hobbit
+(define (hobbit . args)
+  (require 'hobbit)
+  (apply hobbit args)))
+
+(define (compile-file file . args)
+  (require 'glob)
+  (apply hobbit file args)
+  (let ((command
+	 (list "build"
+	       "-hsystem"
+	       "-tdll"
+	       (string-append "--compiler-options=-I" (implementation-vicinity))
+	       "-c" (replace-suffix file (scheme-file-suffix) ".c"))))
+    (require 'build)
+    (cond ((>= (verbose) 3) (write command) (newline)))
+    (build-from-whole-argv command)))
+
+(define (compile->executable name . args)
+  (define sfs (scheme-file-suffix))
+  (require 'glob)
+  (for-each hobbit args)
+  (let ((inits (map (lambda (file)
+		      (string-append "-iinit_" (replace-suffix file sfs "")))
+		    args))
+	(files (map (lambda (file)
+		      (string-append "-c" (replace-suffix file sfs ".c")))
+		    args)))
+    (define command (append (list "build"
+				  "-hsystem"
+				  "--type=exe"
+				  "-o" name
+				  "-F" "compiled-closure" "inexact"
+				  (string-append "--linker-options=-L"
+						 (implementation-vicinity)))
+			    files
+			    inits))
+    (require 'build)
+    (cond ((>= (verbose) 3) (write command) (newline)))
+    (build-from-whole-argv command)))
+
+(go-script)
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End:
diff --git a/continue.c b/continue.c
index f08f4bc..a72ce4b 100644
--- a/continue.c
+++ b/continue.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -156,7 +156,7 @@ void free_continuation(cont)
    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.
+   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
diff --git a/continue.h b/continue.h
index d16338f..42a5ff5 100644
--- a/continue.h
+++ b/continue.h
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -63,8 +63,10 @@
     extern int longjump(jump_buf env, int ret);
 
 # else				/* ndef _CRAY1 */
-#  include <setjmp.h>
-#  include <signal.h>
+#  ifndef PLAN9
+#   include <setjmp.h>
+#   include <signal.h>
+#  endif
 #  ifdef SIG_UNBLOCK
 #   define jump_buf sigjmp_buf
 #   define setjump(buf) sigsetjmp((buf), !0)
diff --git a/crs.c b/crs.c
index bab7c52..665b0bd 100644
--- a/crs.c
+++ b/crs.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -43,7 +43,12 @@
    Author: Aubrey Jaffer */
 
 #include "scm.h"
-#include <curses.h>
+
+#ifdef __FreeBSD__
+# include <ncurses.h>
+#else
+# include <curses.h>
+#endif
 
 #ifdef MWC
 # include <unctrl.h>
@@ -93,10 +98,8 @@ SCM mkwindow(win)
 {
   SCM z;
   if (NULL==win) return BOOL_F;
-  NEWCELL(z);
   DEFER_INTS;
-  SETCHARS(z, win);
-  CAR(z) = scm_port_entry(tc16_window, OPN | RDNG | WRTNG);
+  z = scm_port_entry((FILE *)win, tc16_window, OPN | RDNG | WRTNG);
   ALLOW_INTS;
   return z;
 }
diff --git a/debug.c b/debug.c
new file mode 100644
index 0000000..22c387b
--- /dev/null
+++ b/debug.c
@@ -0,0 +1,751 @@
+/* Copyright (C) 2001 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, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of SCM.
+ *
+ * The exception is that, if you link the SCM 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 SCM 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 SCM.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * SCM, 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 SCM, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "debug.c" procedures for displaying and debugging code.
+   Authors: Radey Shouman & Aubrey Jaffer. */
+
+#include "scm.h"
+#include "setjump.h"
+
+long tc16_codeptr;		/*  Type code for non-executable code
+				    wrappers */
+
+static SCM prinhead P((SCM x, SCM port, int writing));
+static void prinbindings P((SCM names, SCM inits, SCM init_env,
+			    SCM steps, SCM step_env, SCM port, int writing));
+
+SCM scm_env_rlookup(addr, stenv, what)
+     SCM addr, stenv;
+     char *what;
+{
+  SCM env, fr;
+  int icdrp;
+  unsigned int idist, iframe;
+  if (IMP(addr)) {
+    if (!ILOCP(addr)) return BOOL_F;
+    iframe = IFRAME(addr);
+    idist = IDIST(addr);
+    icdrp = ICDRP(addr) && 1;
+  }
+  else {
+    if (!ISYMP(CAR(addr))) return BOOL_F;
+    icdrp = 0;
+    switch (ISYMNUM(CAR(addr))) {
+    default: return BOOL_F;
+    case (ISYMNUM(IM_FARLOC_CDR)):
+      icdrp = 1;
+    case (ISYMNUM(IM_FARLOC_CAR)):
+      fr = CDR(addr);
+      iframe = INUM(CAR(fr));
+      idist = INUM(CDR(fr));
+      break;
+    }
+  }
+  for (env = stenv; NIMP(env); env = CDR(env)) {
+    fr = CAR(env);
+    if (INUMP(fr)) {
+      ASSERT(NIMP(env) && CONSP(env), stenv, s_badenv, what);
+      env = CDR(env);
+      continue;
+    }
+    if (SCM_LINUMP(fr)) continue;
+    if (NIMP(fr) && CONSP(fr) && IMP(CAR(fr))) continue;
+    if (0==iframe--) {
+      while (idist--) {
+	if (IMP(fr) || NCONSP(fr)) return BOOL_F;
+	fr = CDR(fr);
+      }
+      if (!icdrp) {
+	if (NIMP(fr) && CONSP(fr))
+	  fr = CAR(fr);
+	else
+	  fr = BOOL_F;
+      }
+      if (NIMP(fr) && IDENTP(fr)) return fr;
+      return BOOL_F;
+    }
+  }
+  return BOOL_F;
+}
+
+SCM scm_env_addprop(prop, val, env)
+     SCM prop, val, env;
+{
+  if (UNBNDP(prop)) return env;
+  return cons2(prop, val, env);
+}
+
+SCM scm_env_getprop(prop, env)
+     SCM prop, env;
+{
+  SCM e = env;
+  if (!UNBNDP(prop)) {
+    while (NIMP(e)) {
+      if (INUMP(CAR(e))) {
+	if (CAR(e)==prop) return CDR(e);
+	e = CDR(e);
+	ASSERT(NIMP(e), env, s_badenv, "env_getprop");
+      }
+      e = CDR(e);
+    }
+  }
+  return BOOL_F;
+}
+
+static SCM prinhead(x, port, writing)
+     SCM x, port;
+     int writing;
+{
+  lputc('(', port);
+  iprin1(CAR(x), port, writing);
+  lputc(' ', port);
+  return CDR(x);
+}
+
+static void prinbindings(names, inits, init_env,
+			 steps, step_env, port, writing)
+     SCM names, inits, init_env, steps, step_env, port;
+     int writing;
+{
+  lputc('(', port);
+  while (NIMP(names) && NIMP(inits)) {
+    lputc('(', port);
+    iprin1(CAR(names), port, writing);
+    lputc(' ', port);
+    scm_princode(CAR(inits), init_env, port, writing);
+    if (NIMP(steps)) {
+      lputc(' ', port);
+      scm_princode(CAR(steps), step_env, port, writing);
+      steps = CDR(steps);
+    }
+    lputc(')', port);
+    names = CDR(names);
+    inits = CDR(inits);
+    if (NIMP(names)) lputc(' ', port);
+  }
+  lputs(") ", port);
+}
+
+void scm_princode(code, env, port, writing)
+     SCM code, env, port;
+     int writing;
+{
+  SCM oenv = env, name, init, bdgs, x = code;
+  if (UNBNDP(env)) {
+    iprin1(code, port, writing);
+    return;
+  }
+ tail:
+  if (IMP(x)) {
+    if (ILOCP(x)) {
+    local:
+      name = scm_env_rlookup(x, env, "princode");
+      if (FALSEP(name)) goto gencase;
+      lputs("#@", port);
+      iprin1(name, port, writing);
+      return;
+    }
+    else
+      goto gencase;
+  }
+  if (SCM_GLOCP(x)) {
+    iprin1(x, port, writing);
+    return;
+  }
+  switch (TYP7(x)) {
+  default: gencase:
+    iprin1(x, port, writing);
+    return;
+  gencode:
+  case tcs_cons_gloc:
+  case tcs_cons_nimcar:
+  case tcs_cons_iloc:
+  case (127 & IM_OR): case (127 & IM_AND): case (127 & IM_BEGIN):
+  case (127 & IM_SET): case (127 & IM_COND): case (127 & IM_CASE):
+  case (127 & IM_IF):
+    lputc('(', port);
+    scm_princode(CAR(x), env, port, writing);
+  body:
+    x = CDR(x);
+  no_cdr:
+    for (; NNULLP(x); x = CDR(x)) {
+      if (IMP(x) || NECONSP(x)) {
+	lputs(" . ", port);
+	iprin1(x, port, writing);
+	break;
+      }
+      lputc(' ', port);
+      scm_princode(CAR(x), env, port, writing);
+    }
+    lputc(')', port);
+    return;
+  case (127 & IM_LAMBDA):
+    x = prinhead(x, port, writing);
+    env = CAR(x);
+    bdgs = SCM_ENV_FORMALS(env);
+    if (IMP(bdgs) || NECONSP(bdgs))
+      iprin1(bdgs, port, writing);
+    else {
+      lputc('(', port);
+      while (!0) {
+	if (NECONSP(bdgs)) break;
+	iprin1(CAR(bdgs), port, writing);
+	if (NIMP(bdgs = CDR(bdgs)))
+	  lputc(' ', port);
+	else break;
+      }
+      if (NIMP(bdgs)) {
+	lputs(". ", port);
+	iprin1(bdgs, port, writing);
+      }
+      lputc(')', port);
+    }
+    goto body;
+  case (127 & IM_LETREC):
+  case (127 & IM_LET):
+    x = prinhead(x, port, writing);
+    env = CAR(x);
+    prinbindings(SCM_ENV_FORMALS(env),
+		 CAR(CDR(x)), (TYP7(x)==(127 & IM_LET) ? oenv: env),
+		 UNDEFINED, UNDEFINED, port, writing);
+    x = CDR(x);
+    goto body;
+  case (127 & IM_LETSTAR):
+    x = prinhead(x, port, writing);
+    lputc('(', port);
+    if (NIMP(bdgs = CAR(x))) {
+      oenv = CAR(bdgs);
+      bdgs = CDR(bdgs);
+      while (!0) {
+	init = CAR(bdgs);
+	bdgs = CDR(bdgs);
+	env = CAR(bdgs);
+	lputc('(', port);
+	iprin1(SCM_ENV_FORMALS(env), port, writing);
+	lputc(' ', port);
+	scm_princode(init, oenv, port, writing);
+	oenv = env;
+	lputc(')', port);
+	if (IMP(bdgs = CDR(bdgs)))
+	  break;
+	lputc(' ', port);
+      }
+    }
+    lputs(") ", port);
+    goto body;
+  case (127 & IM_DO):
+    {
+      /* (#@do (env (init ...) (test ...) (body ...) step ...)) */
+      SCM test, steps;
+      x = prinhead(x, port, writing);
+      env = CAR(x);
+      x = CDR(x);
+      init = CAR(x);
+      x = CDR(x);
+      test = CAR(x);
+      x = CDR(x);
+      steps = CDR(x);
+      x = CAR(x);
+      prinbindings(SCM_ENV_FORMALS(env), init, oenv, steps, env,
+		   port, writing);
+      scm_princode(test, env, port, writing);
+      lputc(' ', port);
+      goto no_cdr;
+    }
+  case (127 & IM_FUNCALL):
+    lputc('(', port);
+    x = CDR(x);
+    scm_princode(CAR(x), env, port, writing);
+    goto body;
+  case (127 & MAKISYM(0)):
+    if (!ISYMP(CAR(x))) goto gencode;
+    switch (ISYMNUM(CAR(x))) {
+    default:
+      goto gencode;
+    case ISYMNUM(IM_LINUM):
+      x = CDR(x);
+      goto tail;
+    case ISYMNUM(IM_FARLOC_CAR):
+    case ISYMNUM(IM_FARLOC_CDR):
+      goto local;
+    }
+  }
+}
+
+void scm_princlosure(proc, port, writing)
+     SCM proc, port;
+     int writing;
+{
+  SCM env, linum = UNDEFINED;
+  proc = CODE(proc);
+  lputs("#<CLOSURE ", port);
+  env = CAR(proc);
+#ifdef CAUTIOUS
+  if (NIMP(env=scm_env_getprop(SCM_ENV_PROCNAME, env))) {
+    iprin1(CAR(env), port, 1);
+    lputc(' ', port);
+    env = CDR(env);
+    if (NIMP(env) && SCM_LINUMP(CAR(env)))
+      linum = CAR(env);
+  }
+  else
+    lputs("<anon> ", port);
+  env = CAR(proc);
+  if (NIMP(env=scm_env_getprop(SCM_ENV_FILENAME, env)))
+    scm_line_msg(CAR(env), linum, port);
+#endif
+  env = CAR(proc);
+  iprin1(SCM_ENV_FORMALS(env), port, writing);
+  if (writing) {
+    for(proc = CDR(proc); NIMP(proc); proc = CDR(proc)) {
+      lputc(' ', port);
+      scm_princode(CAR(proc), env, port, writing);
+    }
+  }
+  lputc('>', port);
+}
+
+static char s_int2linum[] = "integer->line-number";
+SCM scm_int2linum(n)
+     SCM n;
+{
+  int i = INUM(n);
+  ASSERT(INUMP(n) && i >= 0, n, ARG1, s_int2linum);
+  return SCM_MAKE_LINUM(i);
+}
+
+static char s_linum2int[] = "line-number->integer";
+SCM scm_linum2int(linum)
+     SCM linum;
+{
+  ASSERT(SCM_LINUMP(linum), linum, ARG1, s_linum2int);
+  return MAKINUM(SCM_LINUM(linum));
+}
+
+SCM scm_linump(obj)
+     SCM obj;
+{
+  return SCM_LINUMP(obj) ? BOOL_T : BOOL_F;
+}
+
+static char s_remove_linums[] = "remove-line-numbers!";
+SCM scm_remove_linums(x)
+     SCM x;
+{
+  SCM ret = x;
+  SCM *px = &ret;
+ tail:
+  x = *px;
+  if (IMP(x)) return ret;
+  if (CONSP(x)) {
+    if (SCM_LINUMP(CAR(x))) {
+      *px = CDR(x);
+      px = &CDR(x);
+      goto tail;
+    }
+    if (NIMP(CAR(x)))
+      CAR(x) = scm_remove_linums(CAR(x));
+    px = &CDR(x);
+    goto tail;
+  }
+  else if (VECTORP(x)) {
+    SCM *ve = VELTS(x);
+    sizet i = LENGTH(x);
+    while (i--) {
+      if (NIMP(ve[i]))
+	ve[i] = scm_remove_linums(ve[i]);
+    }
+    return ret;
+  }
+  else
+    return ret;
+}
+
+#ifdef CAUTIOUS
+long num_frames(estk, i)
+     SCM estk;
+     int i;
+{
+  long n = 0;
+  while NIMP(estk) {
+    n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
+    i = INUM(SCM_ESTK_PARENT_INDEX(estk));
+    estk = SCM_ESTK_PARENT(estk);
+  }
+  return n;
+}
+
+SCM *estk_frame(estk, i, nf)
+     SCM estk;
+     int i, nf;
+{
+  int n;
+  /* Make this 1-based, because continuations have an extra frame at
+     the top of the estk. */
+  nf -= 1;
+  while NIMP(estk) {
+    n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
+    if (nf <= n) return &(VELTS(estk)[i - nf*SCM_ESTK_FRLEN]);
+    nf -= n;
+    i = INUM(SCM_ESTK_PARENT_INDEX(estk));
+    estk = SCM_ESTK_PARENT(estk);
+  }
+  return (SCM *)0;
+}
+
+SCM stacktrace1(estk, i)
+     SCM estk;
+     int i;
+{
+  SCM *frame, env, ste, lste = UNDEFINED;
+  int n, nf = num_frames(estk, i);
+  int nbrk1 = 7, nbrk2 = nf - 6;
+  if (nf <= 0) return BOOL_F;
+  lputs("\n;STACK TRACE", cur_errp);
+  for (n = 1; n <= nf; n++) {
+    if ((0 <= nbrk1--) || n >= nbrk2) {
+      if (!(frame = estk_frame(estk, i, n))) continue;
+      if (BOOL_F==(ste = frame[3])) continue;
+      env = frame[2];
+      if (ste != lste) {
+	lste = ste;
+	if (reset_safeport(sys_safep, 65, cur_errp)) {
+	  /* The usual C setjmp, not SCM's setjump. */
+	  if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
+	    lputc('\n', cur_errp);
+	    intprint((long)n, -10, sys_safep);
+	    lputs("; ", sys_safep);
+	    scm_princode(ste, env, sys_safep, 1);
+	  }
+	}
+      }
+      else {
+	lputs("\n...", cur_errp);
+	break;
+      }
+    }
+  }
+  lputc('\n', cur_errp);
+  return BOOL_T;
+}
+
+SCM *cont_frame(contin, nf)
+     SCM contin;
+     int nf;
+{
+  CONTINUATION *cont = CONT(contin);
+  SCM estk = cont->other.estk;
+  int i = LENGTH(estk) - SCM_ESTK_FRLEN;
+  if (0 == nf) return cont->other.stkframe;
+  return estk_frame(estk, i, nf);
+}
+
+static char s_stack_trace[] = "stack-trace";
+SCM scm_stack_trace(contin)
+     SCM contin;
+{
+  SCM estk;
+  int i;
+  if (UNBNDP(contin)) {
+    estk = scm_estk;
+    i = (scm_estk_ptr - VELTS(scm_estk));
+  }
+  else {
+    CONTINUATION *cont;
+    ASSERT(NIMP(contin) && (tc7_contin==TYP7(contin)), contin, ARG1,
+	   s_stack_trace);
+    cont = CONT(contin);
+    estk = cont->other.estk;
+    i = LENGTH(estk) - SCM_ESTK_FRLEN;
+  }
+  return stacktrace1(estk, i);
+}
+
+static char s_frame_trace[] = "frame-trace";
+SCM scm_frame_trace(contin, nf)
+     SCM contin, nf;
+{
+    SCM *stkframe, code, env;
+    ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+	   s_frame_trace);
+    ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_trace);
+    if (!(stkframe = cont_frame(contin, INUM(nf))))
+      return BOOL_F;
+    env = stkframe[2];
+    code = stkframe[3];
+    scm_princode(code, env, cur_errp, 1);
+    scm_scope_trace(env);
+    return UNSPECIFIED;
+}
+
+static char s_frame2env[] = "frame->environment";
+SCM scm_frame2env(contin, nf)
+     SCM contin, nf;
+{
+    SCM *stkframe;
+    ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+	   s_frame2env);
+    ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame2env);
+    if (!(stkframe = cont_frame(contin, INUM(nf))))
+      return BOOL_F;
+    return stkframe[2];
+}
+
+static char s_frame_eval[] = "frame-eval";
+SCM scm_frame_eval(contin, nf, expr)
+     SCM contin, nf, expr;
+{
+    SCM res, env, *stkframe;
+    ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+	   s_frame_eval);
+    ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_eval);
+    if (!(stkframe = cont_frame(contin, INUM(nf))))
+      return BOOL_F;
+    env = stkframe[2];
+    if (IMP(expr)) return expr;
+    DEFER_INTS_EGC;
+    res = ceval(expr, env, stkframe[0]);
+    ALLOW_INTS_EGC;
+    return res;
+}
+
+#endif
+
+static char s_scope_trace[] = "scope-trace";
+SCM scm_scope_trace(env)
+     SCM env;
+{
+  SCM ef, file = UNDEFINED;
+  int fprinted = 0;
+  if (UNBNDP(env))
+    env = scm_current_env();
+  else if (NIMP(env) && CLOSUREP(env))
+    env = CAR(CODE(env));
+  if (scm_nullenv_p(env))
+    lputs("\n; in top level environment.", cur_errp);
+  else
+    lputs("\n; in scope:", cur_errp);
+#ifdef CAUTIOUS
+  if (NIMP(ef=scm_env_getprop(SCM_ENV_FILENAME, env))) {
+    file = CAR(ef);
+  }
+#endif
+  for (; NIMP(env); env = CDR(env)) {
+    if (NCONSP(env)) {
+    badenv:
+      lputs("\n; corrupted environment ", cur_errp);
+      iprin1(env, cur_errp, 1);
+      return UNSPECIFIED;
+    }
+    ef = CAR(env);
+    if (SCM_LINUMP(ef)) {
+      lputs("\n;   ", cur_errp);
+      scm_line_msg(file, ef, cur_errp);
+      fprinted++;
+    }
+    else if (INUMP(ef)) {
+      ASRTGO(NIMP(env) && CONSP(env), badenv);
+      env = CDR(env);
+#ifdef CAUTIOUS
+      switch (ef) {
+      default: break;
+      case SCM_ENV_PROCNAME:
+	lputs("  procedure ", cur_errp);
+	iprin1(CAR(env), cur_errp, 1);
+	break;
+      }
+#endif
+    }
+    else if (NIMP(ef) && CONSP(ef) && NIMP(CAR(ef)) && CONSP(CAR(ef))) {
+      lputs("\n;   ", cur_errp);
+      iprin1(CAR(ef), cur_errp, 1);
+      lputs("  syntax bindings", cur_errp);
+    }
+    else {
+      lputs("\n;   ", cur_errp);
+      iprin1(ef, cur_errp, 1);
+    }
+  }
+#ifdef CAUTIOUS
+  if (NIMP(file) && !fprinted) {
+    lputs("\n; defined by ", cur_errp);
+    if (NIMP(file) && STRINGP(file))
+      lputs("load: ", cur_errp);
+    iprin1(file, cur_errp, 1);
+    lputc('\n', cur_errp);
+  }
+#endif
+  return UNSPECIFIED;
+}
+
+static char s_env_annotation[] = "environment-annotation";
+SCM scm_env_annotation(var, stenv)
+     SCM var, stenv;
+{
+  SCM s, frame, env = stenv;
+#ifdef MACRO
+  SCM mark = IDENT_ENV(var);
+  if (NIMP(mark)) mark = CAR(mark);
+#endif
+  for (; NIMP(env); env = CDR(env)) {
+    frame = CAR(env);
+#ifdef MACRO
+    if (frame==mark) {
+      var = IDENT_PARENT(var);
+      mark = IDENT_ENV(var);
+      if (NIMP(mark)) mark = CAR(mark);
+    }
+#endif
+    if (IMP(frame)) {
+      if (INUMP(frame)) {
+#ifndef RECKLESS
+	if (!(NIMP(env) && CONSP(env))) {
+	badenv: wta(stenv, s_badenv, s_env_annotation);
+	}
+#endif
+	env = CDR(env);
+      }
+      continue;
+    }
+#ifdef MACRO
+    if (NIMP(frame) && CONSP(frame) && BOOL_F==CAR(frame)) {
+      /* syntax binding */
+      s = assq(var, CDR(frame));
+      if (NIMP(s)) goto local_out;
+      continue;
+    }
+#endif
+    for (; NIMP(frame); frame = CDR(frame)) {
+      if (NCONSP(frame)) {
+	if (var==frame)
+	  goto local_out;
+	break;
+      }
+      if (CAR(frame)==var) {
+      local_out:
+	env = CDR(env);
+	if (IMP(env)) return BOOL_T;
+	if (SCM_ENV_ANNOTATION != CAR(env)) return BOOL_T;
+	env = CDR(env);
+	ASRTGO(NIMP(env), badenv);
+	s = assq(var, CAR(env));
+	if (NIMP(s)) return s;
+	return BOOL_T;
+      }
+      ASRTGO(CONSP(frame), badenv);
+    }
+  }
+  ASRTGO(NULLP(env), badenv);
+  return BOOL_F;
+}
+
+/* This is to be used for code backpointers to go into environments,
+   allowing run-time reporting of error line numbers. */
+SCM scm_wrapcode(code, env)
+     SCM code, env;
+{
+  SCM z, x = cons(env, code);
+  NEWCELL(z);
+  CDR(z) = x;
+  CAR(z) = tc16_codeptr;
+  return z;
+}
+
+static int princodeptr(exp, port, writing)
+     SCM exp;
+     SCM port;
+     int writing;
+{
+  SCM env = CAR(CDR(exp));
+  lputs("#<code ", port);
+  exp = CDR(CDR(exp));
+  if (IMP(exp) || NCONSP(exp))
+    scm_princode(exp, env, port, writing);
+  else {
+    while (!0) {
+      if (IMP(exp) || NCONSP(exp)) break;
+      scm_princode(CAR(exp), env, port, writing);
+      lputc(' ', port);
+      exp = CDR(exp);
+    }
+    if (NNULLP(exp)) {
+      lputs(" . ", port);
+      scm_princode(exp, env, port, writing);
+    }
+  }
+  lputc('>', port);
+  return !0;
+}
+
+static smobfuns codesmob = {markcdr, free0, princodeptr};
+
+static iproc subr1os[] = {
+  {s_scope_trace, scm_scope_trace},
+#ifdef CAUTIOUS
+  {s_stack_trace, scm_stack_trace},
+#endif
+	{0, 0}};
+
+static iproc subr1s[] = {
+  {s_int2linum, scm_int2linum},
+  {"line-number?", scm_linump},
+  {s_linum2int, scm_linum2int},
+  {s_remove_linums, scm_remove_linums},
+  {0, 0}};
+
+static iproc subr2s[] = {
+  {s_env_annotation, scm_env_annotation},
+#ifdef CAUTIOUS
+  {s_frame_trace, scm_frame_trace},
+  {s_frame2env, scm_frame2env},
+#endif
+  {0, 0}};
+
+void init_debug()
+{
+  tc16_codeptr = newsmob(&codesmob);
+  init_iprocs(subr1os, tc7_subr_1o);
+  init_iprocs(subr1s, tc7_subr_1);
+  init_iprocs(subr2s, tc7_subr_2);
+#ifdef CAUTIOUS
+  make_subr(s_frame_eval, tc7_subr_3, scm_frame_eval);
+#endif
+}
diff --git a/disarm.scm b/disarm.scm
index 289f893..2492d72 100644
--- a/disarm.scm
+++ b/disarm.scm
@@ -15,26 +15,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.  
 
diff --git a/dynl.c b/dynl.c
index 3469199..d965840 100644
--- a/dynl.c
+++ b/dynl.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -352,10 +352,15 @@ void init_dynl()
 
 # define SHL(obj) ((void*)CDR(obj))
 
-# ifdef SVR4		/* Solaris 2. */
-#  define DLOPEN_MODE	RTLD_LAZY
+# ifdef RTLD_GLOBAL
+#  define DLOPEN_MODE (RTLD_NOW | RTLD_GLOBAL)
 # else
-#  define DLOPEN_MODE	1	/* Thats what it says in the man page. */
+#  ifdef RTLD_LAZY		/* This is here out of conservatism, not
+				   because it's known to be right. */
+#   define DLOPEN_MODE RTLD_LAZY
+#  else
+#   define DLOPEN_MODE 1	/* Thats what it says in the man page. */
+#  endif
 # endif
 
 sizet frshl(ptr)
@@ -393,7 +398,7 @@ SCM l_dyn_link(fname)
   DEFER_INTS;
   handle = dlopen(CHARS(fname), DLOPEN_MODE);
   if (NULL==handle) {
-    if (verbose > 2) {
+    if (verbose > 1) {
       char *dlr = dlerror();
       ALLOW_INTS;
       if (dlr) {
diff --git a/edline.c b/edline.c
index 73b88e1..d3a338a 100644
--- a/edline.c
+++ b/edline.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -59,8 +59,8 @@ SCM lreadline(prompt)
   if (NULL == s) return EOF_VAL;
   NEWCELL(res);
   DEFER_INTS;
-  SETCHARS(res,s);
-  SETLENGTH(res,(sizet)strlen(s),tc7_string);
+  SETCHARS(res, s);
+  SETLENGTH(res, strlen(s), tc7_string);
   ALLOW_INTS;
   return res;
 }
diff --git a/eval.c b/eval.c
index ee4975d..7b0e983 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002 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
@@ -15,32 +15,32 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, 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. */
+   Authors: Radey Shouman, Aubrey Jaffer, & Hugh E. Secker-Walker. */
 
 #include "scm.h"
 #include "setjump.h"
@@ -48,7 +48,10 @@
 #define I_SYM(x) (CAR((x)-1L))
 #define I_VAL(x) (CDR((x)-1L))
 #define ATOMP(x) (5==(5 & (int)CAR(x)))
-#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x)))
+#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x, 0):ceval_1(CAR(x)))
+#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
+#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
+					I_VAL(CAR(x))):EVALCELLCAR(x))
 
 /* Environment frames are initially allocated in a small cache ("ecache").
   This cache is subject to copying gc, cells in it may be moved to the
@@ -81,63 +84,106 @@
   might have been allocated in the ecache may be passed using the
   global variables scm_env_tmp and scm_env.
 
-  If the CDR of a cell that might be allocated in the regular heap is
+  If the CAR of a cell that might be allocated in the regular heap is
   made to point to a cell allocated in the cache, then the first cell
   must be recorded as a gc root, using the macro EGC_ROOT.  There is
-  no provision for allowing the CAR of a regular cell to point to a
+  no provision for allowing the CDR of a regular cell to point to a
   cache cell.  */
 
 #ifdef NO_ENV_CACHE
-# define scm_env_cons(a,b) {scm_env_tmp=cons((a),(b));}
-# define scm_env_cons2(a,b,c) {scm_env_tmp=cons2((a),(b),(c));}
-# define scm_env_cons_tmp(a) {scm_env_tmp=cons((a),scm_env_tmp);}
-# define EXTEND_ENV(names) {scm_env=acons((names),scm_env_tmp,scm_env);}
+# define scm_env_cons(a, b) {scm_env_tmp=cons((a), (b));}
+# define scm_env_cons2(a, b, c) {scm_env_tmp=cons2((a), (b), (c));}
+# define scm_env_cons3(a, b, c, d) {scm_env_tmp=cons2((a), (b), cons((c), (d)));}
+# define EXTEND_VALENV {scm_env=cons(scm_env_tmp, scm_env);}
+# define ENV_V2LST(argc, argv) \
+   {scm_env_tmp=scm_v2lst((argc), (argv), scm_env_tmp);}
 #else
-# define EXTEND_ENV scm_extend_env
+# define EXTEND_VALENV {scm_extend_env();}
+# define ENV_V2LST scm_env_v2lst
 #endif
+#define EXTEND_ENV cons
 
 SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
 long tc16_env;			/* Type code for environments passed to macro
 				   transformers. */
+
 SCM nconc2copy P((SCM x));
-SCM copy_list P((SCM x, int minlen));
-SCM scm_v2lst P((long argc, SCM *argv));
-SCM rename_ident P((SCM id, SCM env));
-SCM *lookupcar P((SCM vloc, int check));
+SCM scm_cp_list P((SCM x, int minlen));
+SCM scm_v2lst P((long argc, SCM *argv, SCM end));
+SCM renamed_ident P((SCM id, SCM env));
 SCM eqv P((SCM x, SCM y));
 SCM scm_multi_set P((SCM syms, SCM vals));
 SCM eval_args P((SCM x));
+SCM m_quote P((SCM xorig, SCM env, SCM ctxt));
+SCM m_begin P((SCM xorig, SCM env, SCM ctxt));
+SCM m_if P((SCM xorig, SCM env, SCM ctxt));
+SCM m_set P((SCM xorig, SCM env, SCM ctxt));
+SCM m_and P((SCM xorig, SCM env, SCM ctxt));
+SCM m_or P((SCM xorig, SCM env, SCM ctxt));
+SCM m_cond P((SCM xorig, SCM env, SCM ctxt));
+SCM m_case P((SCM xorig, SCM env, SCM ctxt));
+SCM m_lambda P((SCM xorig, SCM env, SCM ctxt));
+SCM m_letstar P((SCM xorig, SCM env, SCM ctxt));
+SCM m_do P((SCM xorig, SCM env, SCM ctxt));
+SCM m_quasiquote P((SCM xorig, SCM env, SCM ctxt));
+SCM m_delay P((SCM xorig, SCM env, SCM ctxt));
+SCM m_define P((SCM xorig, SCM env, SCM ctxt));
+SCM m_letrec P((SCM xorig, SCM env, SCM ctxt));
+SCM m_let P((SCM xorig, SCM env, SCM ctxt));
+SCM m_apply P((SCM xorig, SCM env, SCM ctxt));
+SCM m_syn_quote P((SCM xorig, SCM env, SCM ctxt));
+SCM m_define_syntax P((SCM xorig, SCM env, SCM ctxt));
+SCM m_let_syntax P((SCM xorig, SCM env, SCM ctxt));
+SCM m_letrec_syntax P((SCM xorig, SCM env, SCM ctxt));
+SCM m_the_macro P((SCM xorig, SCM env, SCM ctxt));
 void scm_dynthrow P((SCM cont, SCM val));
 void scm_egc P((void));
 void scm_estk_grow P((void));
 void scm_estk_shrink P((void));
-int badargsp P((SCM proc, SCM args));
+int badargsp P((SCM formals, SCM args));
 
+static SCM *lookupcar P((SCM vloc));
+static SCM scm_lookupval P((SCM vloc, int memo));
 static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args));
 static SCM ceval_1 P((SCM x));
-static SCM evalatomcar P((SCM x));
+static SCM evalatomcar P((SCM x, int toplevelp));
 static SCM evalcar P((SCM x));
 static SCM id2sym P((SCM id));
 static SCM iqq P((SCM form));
-static SCM m_body P((SCM op, SCM xorig, char *what));
-static SCM m_expand_body P((SCM xorig));
-static SCM m_iqq P((SCM form, int depth, SCM env));
-static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env));
-static SCM macroexp1 P((SCM x, SCM defs));
-static SCM unmemocar P((SCM x));
-static SCM wrapenv P((void));
-static SCM *id_denote P((SCM var));
+static SCM m_body P((SCM xorig, SCM env, SCM ctxt));
+static SCM m_iqq P((SCM form, int depth, SCM env, SCM ctxt));
+static SCM m_parse_let P((SCM imm, SCM xorig, SCM x, SCM *vars, SCM *inits));
+static SCM m_let_null P((SCM body, SCM env, SCM ctxt));
+static SCM m_letrec1 P((SCM imm, SCM xorig, SCM env, SCM ctxt));
+static SCM m_letstar1 P((SCM imm, SCM vars, SCM inits, SCM body,
+			 SCM env, SCM ctxt));
+static SCM macroexp1 P((SCM x, SCM env, SCM ctxt, int mode));
+/* static int checking_defines_p P((SCM ctxt)); */
+/* static SCM wrapenv P((void)); */
+static SCM scm_case_selector P((SCM x));
+static SCM acro_call P((SCM x, SCM env));
+static SCM m_binding P((SCM name, SCM value, SCM env, SCM ctxt));
+static SCM m_bindings P((SCM name, SCM value, SCM env, SCM ctxt));
+static SCM m_seq P((SCM x, SCM env, SCM ctxt));
+static SCM m_expr P((SCM x, SCM env, SCM ctxt));
+static void checked_define P((SCM name, SCM val, char *what));
+static int topdenote_eq P((SCM sym, SCM id, SCM env));
+static int constant_p P((SCM x));
 static int prinenv P((SCM exp, SCM port, int writing));
 static int prinid P((SCM exp, SCM port, int writing));
 static int prinmacro P((SCM exp, SCM port, int writing));
 static int prinprom P((SCM exp, SCM port, int writing));
+#ifdef MAC_INLINE
+static int env_depth P((void));
+static void env_tail P((int depth));
+#endif
 static void unpaint P((SCM *p));
 static void ecache_evalx P((SCM x));
 static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x));
-static int varcheck P((SCM xorig, SCM vars, char *op, char *what));
+static int varcheck P((SCM vars, SCM op, char *what));
 #ifdef CAREFUL_INTS
-static void debug_env_warn P((char *fnam, long line, char *what));
-static void debug_env_save P((char *fnam, long line));
+static void debug_env_warn P((char *fnam, int line, char *what));
+static void debug_env_save P((char *fnam, int line));
 #endif
 
 /* Flush global variable state to estk. */
@@ -150,9 +196,11 @@ static void debug_env_save P((char *fnam, long line));
 /* Make global variable state consistent with estk. */
 #define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];}
 
-#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\
-                  if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\
-		  else scm_estk_ptr += SCM_ESTK_FRLEN;}
+#define ENV_PUSH \
+  {DEFER_INTS_EGC; ENV_SAVE;\
+   if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\
+   else scm_estk_ptr += SCM_ESTK_FRLEN;\
+   STATIC_ENV=scm_estk_ptr[2 - SCM_ESTK_FRLEN];}
 
 #define ENV_POP {DEFER_INTS_EGC;\
                  if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\
@@ -163,7 +211,7 @@ static void debug_env_save P((char *fnam, long line));
 #else
 # ifdef CAREFUL_INTS
 #  define EGC_ROOT(x) {if (!ints_disabled) \
-                          debug_env_warn(__FILE__,__LINE__,"EGC_ROOT"); \
+                          debug_env_warn(__FILE__, __LINE__, "EGC_ROOT"); \
                        scm_egc_roots[--scm_egc_root_index] = (x); \
                        if (0==scm_egc_root_index) scm_egc();}
 # else
@@ -172,41 +220,47 @@ static void debug_env_save P((char *fnam, long line));
 # endif
 #endif
 
-#ifdef CAUTIOUS
-SCM scm_trace = UNDEFINED;
+#ifndef RECKLESS
+SCM scm_trace = BOOL_F;
+SCM scm_trace_env = EOL;
 #endif
 #define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;}
 #define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;}
 #define SIDEVAL_1(x) if NIMP(x) ceval_1(x)
+#define STATIC_ENV (scm_estk_ptr[2])
 #ifdef CAUTIOUS
-# define TRACE(x) {scm_estk_ptr[2]=(x);}
-# define TOP_TRACE(x) {scm_trace=(x);}
-# define PUSH_TRACE TRACE(scm_trace)
+# define TRACE(x) {scm_estk_ptr[3]=(x);}
+# define TOP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);}
 #else
 # define TRACE(x) /**/
-# define TOP_TRACE(x) /**/
-# define PUSH_TRACE /**/
+# define TOP_TRACE(x, env) /**/
+#endif
+#ifndef RECKLESS
+# define MACROEXP_TRACE(x, env) {scm_trace=(x); scm_trace_env=(env);}
+#else
+# define MACROEXP_TRACE(x, env) /**/
 #endif
 
-#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
-#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
-					I_VAL(CAR(x))):EVALCELLCAR(x))
 long tc16_macro;		/* Type code for macros */
 #define MACROP(x) (tc16_macro==TYP16(x))
+#define MAC_TYPE	NUMDIGS
+#define MAC_PRIMITIVE	0x1L
+#define MAC_MEMOIZING	0x2L
+#define MAC_ACRO	0x4L
+#define MAC_MACRO	0x8L
+#define MAC_MMACRO	0x2L
+#define MAC_IDMACRO	0x6L
+/*  uncomment this to experiment with inline procedures
+    #define MAC_INLINE	0x10L */
 
 #ifdef MACRO
 long tc16_ident;		/* synthetic macro identifier */
-SCM i_mark;
 static char s_escaped[] = "escaped synthetic identifier";
-# define M_IDENTP(x) (tc16_ident==TYP16(x))
-# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
-# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
-# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x))
-# define IDENT_MARK(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F)
-# define ENV_MARK BOOL_T
+# define KEYWORDP(x) (NIMP(x) && IM_KEYWORD==CAR(x))
+# define KEYWORD_MACRO CDR
 #else
-# define IDENTP SYMBOLP
-# define M_IDENTP(x) (0)
+# define KEYWORDP(x) (NIMP(x) && MACROP(x))
+# define KEYWORD_MACRO(x) (x)
 #endif
 
 /* #define SCM_PROFILE */
@@ -285,12 +339,12 @@ int ecache_p(x)
 }
 static void debug_env_warn(fnam, line, what)
      char *fnam;
-     long line;
+     int line;
      char *what;
 {
   lputs(fnam, cur_errp);
   lputc(':', cur_errp);
-  intprint(line, 10, cur_errp);
+  intprint(line+0L, 10, cur_errp);
   lputs(": unprotected ", cur_errp);
   lputs(what, cur_errp);
   lputs(" of ecache value\n", cur_errp);
@@ -298,7 +352,7 @@ static void debug_env_warn(fnam, line, what)
 SCM *debug_env_car(x, fnam, line)
      SCM x;
      char *fnam;
-     long line;
+     int line;
 {
   SCM *ret;
   if (!ints_disabled && ecache_p(x))
@@ -311,7 +365,7 @@ SCM *debug_env_car(x, fnam, line)
 SCM *debug_env_cdr(x, fnam, line)
      SCM x;
      char *fnam;
-     long line;
+     int line;
 {
   SCM *ret;
   if (!ints_disabled && ecache_p(x))
@@ -323,7 +377,7 @@ SCM *debug_env_cdr(x, fnam, line)
 }
 static void debug_env_save(fnam, line)
      char *fnam;
-     long line;
+     int line;
 {
   if (NIMP(scm_env) && (!scm_cell_p(scm_env)))
     debug_env_warn(fnam, line, "ENV_SAVE (env)");
@@ -339,18 +393,22 @@ SCM *ilookup(iloc)
      SCM iloc;
 {
   register int ir = IFRAME(iloc);
-  register SCM er;
+  register SCM er, *eloc;
 #ifdef SCM_PROFILE
   ilookup_cases[ir<10 ? ir : 9]
     [IDIST(iloc)<10 ? IDIST(iloc) : 9][ICDRP(iloc)?1:0]++;
 #endif
   DEFER_INTS_EGC;
   er = scm_env;
+  /* shortcut the two most common cases. */
+  if (iloc==MAKILOC(0, 0)) return &CAR(CAR(er));
+  if (iloc==MAKILOC(0, 1)) return &CAR(CDR(CAR(er)));
   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));
+  eloc = &CAR(er);
+  for (ir = IDIST(iloc); 0 != ir; --ir)
+    eloc = &CDR(*eloc);
+  if ICDRP(iloc) return eloc;
+  return &CAR(*eloc);
 }
 SCM *farlookup(farloc)
      SCM farloc;
@@ -361,163 +419,214 @@ SCM *farlookup(farloc)
   DEFER_INTS_EGC;
   er = scm_env;
   for (ir = INUM(CAR(x)); 0 != ir; --ir) er = CDR(er);
+  if (0==(ir = INUM(CDR(x)))) {
+    if (IM_FARLOC_CDR==CAR(farloc)) return &CAR(er);
+    return &CAR(CAR(er));
+  }
   er = CAR(er);
-  for (ir = INUM(CDR(x)); 0 != ir; --ir) er = CDR(er);
+  for(--ir;0 != ir;--ir) er = CDR(er);
   if (IM_FARLOC_CDR==CAR(farloc)) return &CDR(er);
   return &CAR(CDR(er));
 }
 
-static char s_badkey[] = "Use of keyword as variable",
-  s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: ";
-/* check is logical OR of LOOKUP_MEMOIZE, LOOKUP_UNDEFP, and LOOKUP_MACROP,
-   if check is zero then memoization will not be done. */
-#define LOOKUP_MEMOIZE 1
-#define LOOKUP_UNDEFP 2
-#define LOOKUP_MACROP 4
-SCM *lookupcar(vloc, check)
-     SCM vloc;
-     int check;
+char s_badenv[] = "damaged environment";
+static char  s_lookup[] = "scm_env_lookup",
+  s_badkey[] = "Use of keyword as variable",
+  s_unbnd[] = "unbound variable: ",
+  s_wtap[] = "Wrong type to apply: ",
+  s_placement[] = "bad placement";
+
+/*
+  Returns:
+    a symbol if VAR is not found in STENV,
+    an ILOC if VAR is bound in STENV,
+    a list (IM_FARLOC iframe idist) if VAR is bound very deeply in STENV,
+    a pair (IM_KEYWORD . <macro>) if VAR is a syntax keyword bound in STENV.
+*/
+SCM scm_env_lookup(var, stenv)
+     SCM var, stenv;
 {
-  SCM env;
+  SCM  frame, env = stenv;
   long icdr = 0L;
-  register SCM *al, fl, var = CAR(vloc);
-  register unsigned int idist, iframe = 0;
+  unsigned int idist, iframe = 0;
 #ifdef MACRO
-  SCM mark = IDENT_MARK(var);
+  SCM mark = IDENT_ENV(var);
+  if (NIMP(mark)) mark = CAR(mark);
 #endif
-  DEFER_INTS_EGC;
-  env = scm_env;
-  if (NIMP(env) && ENVP(env))
-    env = CDR(env);
-  for(; NIMP(env); env = CDR(env)) {
+  for (; NIMP(env); env = CDR(env)) {
     idist = 0;
-    al = &CAR(env);
-    fl = CAR(*al);
+    frame = CAR(env);
 #ifdef MACRO
-    if (fl==mark) {
+    if (frame==mark) {
       var = IDENT_PARENT(var);
-      mark = IDENT_MARK(var);
+      mark = IDENT_ENV(var);
+      if (NIMP(mark)) mark = CAR(mark);
     }
 #endif
-/*     constant environment section -- not used as yet.
-    if (BOOL_T==fl) {
-      fl = assq(var, CDR(fl));
-      if FALSEP(fl) break;
-      var = fl;
-      goto gloc_out;
-    }
-*/
-    for(;NIMP(fl);fl = CDR(fl)) {
-      if NCONSP(fl)
-	if (fl==var) {
-	  icdr = ICDR;
+    if (IMP(frame)) {
+      if (NULLP(frame)) iframe++;
+      else if (INUMP(frame)) {
 #ifndef RECKLESS
-	  fl = CDR(*al);
+	if (!(NIMP(env) && CONSP(env))) {
+	badenv: wta(stenv, s_badenv, s_lookup);
+	}
+#endif
+	env = CDR(env);
+      }
+      else {
+	ASRTGO(SCM_LINUMP(frame), badenv);
+      }
+      continue;
+    }
+#ifdef MACRO
+    if (NIMP(frame) && CONSP(frame) && SCM_ENV_SYNTAX==CAR(frame)) {
+      /* syntax binding */
+      SCM s = assq(var, CDR(frame));
+      if (NIMP(s)) return cons(IM_KEYWORD, CDR(s));
+      continue;
+    }
 #endif
+    for (; NIMP(frame); frame = CDR(frame)) {
+      if (NCONSP(frame)) {
+	if (var==frame) {
+	  icdr = ICDR;
 	  goto local_out;
 	}
-	else break;
-      al = &CDR(*al);
-      if (CAR(fl)==var) {
-#ifndef RECKLESS		/* letrec inits to UNDEFINED */
-	fl = CAR(*al);
-      local_out:
-	if ((check & LOOKUP_UNDEFP)
-	    && UNBNDP(fl)) {env = EOL; goto errout;}
-# ifdef MACRO
-	if ((check & LOOKUP_MACROP)
-	    && NIMP(fl) && MACROP(fl)) goto badkey;
-# endif
-	if ((check) && NIMP(scm_env) && ENVP(scm_env))
-	  everr(vloc, scm_env, var,
-		"run-time reference", "");
-#else  /* ndef RECKLESS */
+	break;
+      }
+      if (CAR(frame)==var) {
       local_out:
+#ifndef TEST_FARLOC
+	var = MAKILOC(iframe, idist) + icdr;
+	if (iframe==IFRAME(var) && idist==IDIST(var))
+	  return var;
+	else
 #endif
-#ifdef MEMOIZE_LOCALS
-	if (check) {
-# ifndef TEST_FARLOC
-	  if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
-	    CAR(vloc) = MAKILOC(iframe, idist) + icdr;
-	  else
-# endif
-	    CAR(vloc) = cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR,
-			      MAKINUM(iframe), MAKINUM(idist));
-	}
-#endif
-	return icdr ? &CDR(*al) : &CAR(*al);
+	  return cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR,
+		       MAKINUM(iframe), MAKINUM(idist));
       }
+      ASRTGO(CONSP(frame), badenv);
       idist++;
     }
     iframe++;
   }
+  ASRTGO(NULLP(env), badenv);
 #ifdef MACRO
-  while M_IDENTP(var) {
-    ASRTGO(IMP(IDENT_MARK(var)), errout);
-    var = IDENT_PARENT(var);
+  while (M_IDENTP(var)) {
+    if (IMP(IDENT_ENV(var)))
+      var = IDENT_PARENT(var);
+    else break;
   }
 #endif
-  var = sym2vcell(var);
- gloc_out:
-#ifndef RECKLESS
-  if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
-    var = CAR(var);
-  errout:
-    everr(vloc, wrapenv(), var,
-# ifdef MACRO
-	  M_IDENTP(var) ? s_escaped :
-# endif
-	  (NULLP(env) ? s_unbnd : "damaged environment"), "");
+  return var;
+}
+
+/* Throws error for macro keywords and undefined variables, always memoizes. */
+static SCM *lookupcar(vloc)
+     SCM vloc;
+{
+  SCM *pv, val, var = CAR(vloc), env = STATIC_ENV;
+  SCM addr = scm_env_lookup(var, env);
+  if (IMP(addr) || ISYMP(CAR(addr))) { /* local ref */
+    DEFER_INTS_EGC;
+    pv = IMP(addr) ? ilookup(addr) : farlookup(addr);
   }
-# ifdef MACRO
-  if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) {
-    var = CAR(var);
-  badkey: everr(vloc, wrapenv(), var, s_badkey, "");
+#ifdef MACRO
+# ifndef RECKLESS
+  else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) { /* local macro binding */
+  badkey: wta(var, s_badkey, "");
   }
 # endif
 #endif
-  if (check) CAR(vloc) = var + 1;
-  return &CDR(var);
+  else {			/* global ref */
+#ifdef MACRO
+    ASSERT(SYMBOLP(addr), var, s_escaped, "");
+#endif
+    val = sym2vcell(addr);
+    addr = val + tc3_cons_gloc;
+    pv = &CDR(val);
+#ifdef MACRO
+    ASRTGO(!KEYWORDP(*pv), badkey);
+#endif
+  }
+  ASSERT(!UNBNDP(*pv) && undefineds != *pv, var, s_unbnd, "");
+  CAR(vloc) = addr;
+  return pv;
 }
 
-static SCM unmemocar(form)
-     SCM form;
+/* Throws error for undefined variables, memoizes if memo is non-zero.
+   For local macros, conses new result. */
+static SCM scm_lookupval(vloc, memo)
+     SCM vloc;
+     int memo;
 {
-  SCM env;
-  register int ir;
-  DEFER_INTS_EGC;
-  env = scm_env;
-  if (NIMP(env) && ENVP(env)) env = CDR(env);
-  if IMP(form) return form;
-  if (1==TYP3(form))
-    CAR(form) = I_SYM(CAR(form));
-  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);
+  SCM val, env = STATIC_ENV, var = CAR(vloc);
+  SCM addr = scm_env_lookup(var, env);
+  if (IMP(addr)) { /* local ref */
+    DEFER_INTS_EGC;
+    val = *ilookup(addr);
   }
-  return form;
+#ifdef MACRO
+  else if (NIMP(addr) && IM_KEYWORD==CAR(addr)) /* local macro binding */
+    val = addr;
+#endif
+  else if (ISYMP(CAR(addr))) {	/* local ref (farloc) */
+    DEFER_INTS_EGC;
+    val = *farlookup(addr);
+  }
+  else {			/* global ref */
+#ifdef MACRO
+    ASSERT(SYMBOLP(addr), var, s_escaped, "");
+#endif
+    addr = sym2vcell(addr);
+    val = CDR(addr);
+    addr += tc3_cons_gloc;
+  }
+  ASSERT(!UNBNDP(val) && val != undefineds, var, s_unbnd, "");
+  if (memo && !KEYWORDP(val))	/* Don't memoize forms to be macroexpanded. */
+    CAR(vloc) = addr;
+  return val;
 }
 
 /* CAR(x) is known to be a cell but not a cons */
-static SCM evalatomcar(x)
+static SCM evalatomcar(x, toplevelp)
      SCM x;
+     int toplevelp;
 {
-  SCM r;
+  SCM ret;
   switch TYP7(CAR(x)) {
   default:
-    everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", "");
-  case tcs_symbols:
+    everr(x, STATIC_ENV, CAR(x), "Cannot evaluate: ", "", 0);
   lookup:
-    return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
+  case tcs_symbols:
+    ret = scm_lookupval(x, !0);
+    if (KEYWORDP(ret)) {
+      SCM argv[3];
+      SCM mac = KEYWORD_MACRO(ret);
+      argv[0] = CAR(x);
+      argv[1] = STATIC_ENV;
+      argv[2] = EOL;
+      switch (MAC_TYPE(mac) & ~MAC_PRIMITIVE) {
+      default:
+#ifdef MACRO
+	if (!toplevelp)
+	  everr(x, argv[1], argv[0], s_badkey, "", 0);
+#endif
+	return ret;
+      case MAC_IDMACRO:
+	ret = scm_cvapply(CDR(mac), 3L, argv);
+	CAR(x) = ret;
+	return evalcar(x);
+      }
+    }
+    return ret;
   case tc7_vector:
 #ifndef RECKLESS
-    if (2 <= verbose) scm_warn("unquoted ", s_vector);
+    if (2 <= verbose) scm_warn("unquoted ", s_vector, CAR(x));
 #endif
-    r = cons2(IM_QUOTE, CAR(x), EOL);
-    CAR(x) = r;
-    return CAR(CDR(r));
+    ret = cons2(IM_QUOTE, CAR(x), EOL);
+    CAR(x) = ret;
+    return CAR(CDR(ret));
   case tc7_smob:
 #ifdef MACRO
     if M_IDENTP(CAR(x)) goto lookup;
@@ -537,7 +646,7 @@ SCM scm_multi_set(syms, vals)
     ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set);
     switch (7 & (int)(CAR(syms))) {
     case 0:
-      loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP);
+      loc = lookupcar(syms);
       break;
     case 1:
       loc = &(I_VAL(CAR(syms)));
@@ -556,6 +665,97 @@ SCM scm_multi_set(syms, vals)
   return res;
 }
 
+static SCM scm_case_selector(x)
+     SCM x;
+{
+  SCM key, keys, *kv, *av;
+  SCM actions, offset;
+  long i, n;
+  int op = ISYMVAL(CAR(x));
+  x = CDR(x);
+  key = EVALCAR(x);
+  x = CDR(x);
+  switch (op) {
+  default: wta(MAKINUM(op), "internal error", s_case);
+  case 0:			/* linear search */
+    keys = CAR(x);
+    kv = VELTS(keys);
+    av = VELTS(CAR(CDR(x)));
+    n = LENGTH(keys);
+    for (i = n - 1; i > 0; i--)
+      if (key == kv[i]) return av[i];
+#ifndef INUMS_ONLY
+    /* Bignum and flonum keys are pessimized. */
+    if (NIMP(key) && NUMP(key))
+      for (i = n - 1; i > 0; i--)
+	if (NFALSEP(eqv(kv[i], key))) return av[i];
+#endif
+    return av[0];
+  case 1:			/* integer jump table */
+    offset = CAR(x);
+    if (INUMP(key))
+      i = INUM(key) - INUM(offset) + 1;
+    else
+      i = 0;
+  jump:
+    actions = CAR(CDR(x));
+    if (i >= 1 && i < LENGTH(actions))
+      return VELTS(actions)[i];
+    else
+      return VELTS(actions)[0];
+  case 2:			/* character jump table */
+    offset = CAR(x);
+    if (ICHRP(key))
+      i = ICHR(key) - ICHR(offset) + 1;
+    else
+      i = 0;
+    goto jump;
+  }
+}
+
+static SCM acro_call(x, env)
+     SCM x, env;
+{
+  SCM proc, argv[3];
+  x = CDR(x);
+  proc = scm_lookupval(x, 0);
+  ASRTGO(KEYWORDP(proc), errout);
+  proc = KEYWORD_MACRO(proc);
+  argv[0] = x;
+  argv[1] = env;
+  argv[2] = EOL;
+  switch (MAC_TYPE(proc) & ~MAC_PRIMITIVE) {
+  default:
+  errout: wta(proc, CHARS(CAR(x)), "macro expected");
+  case MAC_MACRO:
+    x = scm_cvapply(CDR(proc), 3L, argv);
+    if (ilength(x) <= 0)
+      x = cons2(IM_BEGIN, x, EOL);
+    return x;
+  case MAC_ACRO:
+    x = scm_cvapply(CDR(proc), 3L, argv);
+    return cons2(IM_QUOTE, x, EOL);
+  }
+}
+
+static SCM toplevel_define(xorig, env)
+     SCM xorig, env;
+{
+  SCM x = CDR(xorig);
+  SCM name = CAR(x);
+  ASSERT(scm_nullenv_p(env), xorig, s_placement, s_define);
+  ENV_PUSH;
+  x = cons(m_binding(name, CAR(CDR(x)), env, EOL), EOL);
+  x = evalcar(x);
+  ENV_POP;
+  checked_define(name, x, s_define);
+#ifdef SICP
+  return name;
+#else
+  return UNSPECIFIED;
+#endif
+}
+
 SCM eval_args(l)
      SCM l;
 {
@@ -582,7 +782,7 @@ static void ecache_evalx(x)
     argv[i++] = EVALCAR(x);
     x = CDR(x);
   }
-  scm_env_v2lst(i, argv);
+  ENV_V2LST((long)i, argv);
 }
 
 /* result is 1 if right number of arguments, 0 otherwise,
@@ -598,12 +798,12 @@ static int ecache_eval_args(proc, arg1, arg2, arg3, x)
     ecache_evalx(x);
   else
     scm_env_tmp = EOL;
-  scm_env_v2lst(3, argv);
+  ENV_V2LST(3L, argv);
 #ifndef RECKLESS
-  proc = CAR(CODE(proc));
+  proc = SCM_ENV_FORMALS(CAR(CODE(proc)));
+  proc = CDR(proc);
   proc = CDR(proc);
   proc = CDR(proc);
-  proc = CDR(proc);  
   for (; NIMP(proc); proc=CDR(proc)) {
     if IMP(x) return 0;
     x = CDR(x);
@@ -634,9 +834,23 @@ static SCM asubr_apply(proc, arg1, arg2, arg3, args)
       arg3 = CAR(args);
       args = CDR(args);
     }
+  default: return UNDEFINED;
   }
 }
 
+static char s_values[] = "values";
+static char s_call_wv[] = "call-with-values";
+SCM scm_values(arg1, arg2, rest, what)
+     SCM arg1, arg2, rest;
+     char *what;
+{
+  DEFER_INTS_EGC;
+  ASSERT(IM_VALUES_TOKEN==scm_env_tmp, UNDEFINED, "one value expected", what);
+  if (! UNBNDP(arg2))
+    scm_env_cons(arg2, rest);
+  return arg1;
+}
+
     /* the following rewrite expressions and
      * some memoized forms have different syntax */
 
@@ -648,17 +862,35 @@ static char s_variable[] = "bad variable";
 static char s_bad_else_clause[] = "bad ELSE clause";
 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);
+static char s_expr[] = "bad expression";
+#define ASSYNT(_cond, _arg, _pos, _subr)\
+   if(!(_cond))scm_experr(_arg, (char *)_pos, _subr);
+
+/* These symbols are needed by the reader, in repl.c */
+SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
+static SCM i_lambda, i_define, i_let, i_begin, i_arrow, i_else;	/* , i_atbind */
+/* These symbols are passed in the context argument to macro expanders. */
+static SCM i_bind, i_anon, i_side_effect, i_test, i_procedure,
+  i_argument, i_check_defines;
 
-SCM i_dot, i_quote, i_quasiquote, i_lambda, i_define,
-  i_let, i_arrow, i_else, i_unquote, i_uq_splicing;
+static SCM f_begin, f_define;
 
 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
 #ifdef MACRO
-# define TOPDENOTE_EQ(sym, x, env) ((sym)==id2sym(x) && TOPLEVELP(x,env))
-# define TOPLEVELP(x,env) (0==id_denote(x))
+# define TOPLEVELP(x, env) (topdenote_eq(UNDEFINED, (x), (env)))
+# define TOPDENOTE_EQ topdenote_eq
 # define TOPRENAME(v) (renamed_ident(v, BOOL_F))
 
+static int topdenote_eq(sym, id, env)
+     SCM sym, id, env;
+{
+  if (UNBNDP(sym)) {
+    sym = scm_env_lookup(id, env);
+    return NIMP(sym) && SYMBOLP(sym);
+  }
+  return sym==id2sym(id) && sym==scm_env_lookup(id, env);
+}
+
 static SCM id2sym(id)
      SCM id;
 {
@@ -668,36 +900,11 @@ static SCM id2sym(id)
   return id;
 }
 
-static SCM *id_denote(var)
-     SCM var;
-{
-  register SCM *al, fl;
-  SCM env, mark = IDENT_MARK(var);
-  DEFER_INTS_EGC;
-  env = scm_env;
-  if (NIMP(env) && ENVP(env)) env = CDR(env);
-  for(;NIMP(env); env = CDR(env)) {
-    al = &CAR(env);
-    for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
-      if (fl==mark) {
-	var = IDENT_PARENT(var);
-	mark = IDENT_MARK(var);
-      }
-      if NCONSP(fl)
-	if (fl==var) return &CDR(*al);
-	else break;
-      al = &CDR(*al);
-      if (CAR(fl)==var) return &CAR(*al);
-    }
-  }
-# ifndef RECKLESS
-  while M_IDENTP(var) {
-    ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, "");
-    var = IDENT_PARENT(var);
-  }
-# endif
-  return (SCM *)0;
-}
+#else /* def MACRO */
+# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x))
+# define TOPLEVELP(x, env) (!0)
+# define TOPRENAME(v) (v)
+#endif
 
 static void unpaint(p)
      SCM *p;
@@ -705,7 +912,12 @@ static void unpaint(p)
   SCM x;
   while NIMP((x = *p)) {
     if CONSP(x) {
-      if NIMP(CAR(x)) unpaint(&CAR(x));
+      if (NIMP(CAR(x)))
+	unpaint(&CAR(x));
+      else if (SCM_LINUMP(CAR(x))) {
+	*p = CDR(x);
+	continue;
+      }
       p = &CDR(*p);
     }
     else if VECTORP(x) {
@@ -715,93 +927,111 @@ static void unpaint(p)
       p = VELTS(x);
     }
     else {
+#ifdef MACRO
       while M_IDENTP(x) *p = x = IDENT_PARENT(x);
+#endif
       return;
     }
   }
 }
-#else /* def MACRO */
-# define TOPDENOTE_EQ(sym, x, env) ((sym)==(x))
-# define TOPLEVELP(x,env) (!0)
-# define TOPRENAME(v) (v)
-#endif
 
-static SCM m_body(op, xorig, what)
-     SCM op, xorig;
-     char *what;
-{
-  ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
-			/* Don't add another ISYM if one is present already. */
-  if ISYMP(CAR(xorig)) return xorig;
-			/* Retain possible doc string. */
-  if (IMP(CAR(xorig)) || NCONSP(CAR(xorig))) {
-    if NNULLP(CDR(xorig))
-      return cons(CAR(xorig), m_body(op, CDR(xorig), what));
-    return xorig;
-  }
-  return cons2(op, CAR(xorig), CDR(xorig));
-}
-
-SCM m_quote(xorig, env)
-     SCM xorig, env;
+SCM m_quote(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   SCM x = copytree(CDR(xorig));
   ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
-#ifdef MACRO
   DEFER_INTS;
   unpaint(&CAR(x));
   ALLOW_INTS;
-#endif
   return cons(IM_QUOTE, x);
 }
 
-SCM m_begin(xorig, env)
-     SCM xorig, env;
+SCM m_begin(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin);
+  int len = ilength(CDR(xorig));
+  if (0==len) return cons2(IM_BEGIN, UNSPECIFIED, EOL);
+  if (1==len) return CAR(CDR(xorig));
+  ASSYNT(len >= 1, xorig, s_expression, s_begin);
   return cons(IM_BEGIN, CDR(xorig));
 }
 
-SCM m_if(xorig, env)
-     SCM xorig, env;
+static int constant_p(x)
+     SCM x;
 {
-  int len = ilength(CDR(xorig));
+  return IMP(x) ? !0 : (CONSP(x) ? 0 : !IDENTP(x));
+}
+
+SCM m_if(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM test, x = CDR(xorig);
+  int len = ilength(x);
   ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if);
-  return cons(IM_IF, CDR(xorig));
+  test = CAR(x);
+  x = CDR(x);
+  if (FALSEP(test))
+    return 3==len ? CAR(CDR(x)) : UNSPECIFIED;
+  if (constant_p(test))
+    return CAR(x);
+  return cons2(IM_IF, m_expr(test, env, i_test),
+	       cons(m_expr(CAR(x), env, ctxt),
+		    NULLP(CDR(x)) ? EOL :
+		    cons(m_expr(CAR(CDR(x)), env, ctxt), EOL)));
 }
 
-SCM m_set(xorig, env)
-     SCM xorig, env;
+SCM m_set(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM x = CDR(xorig);
+  SCM var, x = CDR(xorig);
   ASSYNT(2==ilength(x), xorig, s_expression, s_set);
-  varcheck(xorig,
-	   (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) :
+  varcheck((NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) :
 	   (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED,
-	   s_set, s_variable);
-  return cons(IM_SET, x);
+	    IM_SET, s_variable);
+  var = CAR(x);
+  x = CDR(x);
+  return cons(IM_SET, cons2(var, m_expr(CAR(x), env, ctxt), EOL));
 }
 
-SCM m_and(xorig, env)
-     SCM xorig, env;
+SCM m_and(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  int len = ilength(CDR(xorig));
+  SCM x = CDR(xorig);
+  int len = ilength(x);
   ASSYNT(len >= 0, xorig, s_test, s_and);
+ tail:
   switch (len) {
-  default: return cons(IM_AND, CDR(xorig));
-  case 1: return CAR(CDR(xorig));
+  default:
+    if (FALSEP(CAR(x))) return BOOL_F;
+    if (constant_p(CAR(x))) {
+      x = CDR(x);
+      len--;
+      goto tail;
+    }
+    return cons(IM_AND, x);
+  case 1: return CAR(x);
   case 0: return BOOL_T;
   }
 }
 
-SCM m_or(xorig, env)
-     SCM xorig, env;
+SCM m_or(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  int len = ilength(CDR(xorig));
+  SCM x = CDR(xorig);
+  int len = ilength(x);
   ASSYNT(len >= 0, xorig, s_test, s_or);
+ tail:
   switch (len) {
-  default: return cons(IM_OR, CDR(xorig));
-  case 1: return CAR(CDR(xorig));
+  default:
+    if (FALSEP(CAR(x))) {
+      x = CDR(x);
+      len--;
+      goto tail;
+    }
+    if (constant_p(CAR(x)))
+      return CAR(x);
+    return cons(IM_OR, x);
+  case 1: return CAR(x);
   case 0: return BOOL_F;
   }
 }
@@ -809,84 +1039,114 @@ SCM m_or(xorig, env)
 #ifdef INUMS_ONLY
 # define memv memq
 #endif
-SCM m_case(xorig, env)
-     SCM xorig, env;
+static SCM *loc_atcase_aux = 0;
+static int in_atcase_aux = 0;
+SCM m_case(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx;
-#ifndef RECKLESS
-  SCM s, keys = EOL;
-#endif
-  ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case);
+  SCM clause, x = CDR(xorig), key_expr = CAR(x);
+  SCM s, keys = EOL, action, actions = EOL, else_action = list_unspecified;
+  int opt = !scm_nullenv_p(env);
+  ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
   while(NIMP(x = CDR(x))) {
     clause = CAR(x);
-    ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case);
-    if TOPDENOTE_EQ(i_else, CAR(clause), env) {
+    s = scm_check_linum(clause, 0L);
+    ASSYNT(ilength(clause) >= 2, clause /* xorig */, s_clauses, s_case);
+    clause = s;
+    if (TOPDENOTE_EQ(i_else, CAR(clause), env)) {
       ASSYNT(NULLP(CDR(x)), xorig, s_bad_else_clause, s_case);
-      CAR(x) = cons(IM_ELSE, CDR(clause));
+      else_action = m_seq(CDR(clause), env, ctxt);
     }
     else {
+      s = scm_check_linum(CAR(clause), 0L);
 #ifdef MACRO
-      SCM c = copy_list(CAR(clause), 0);
-      ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case);
-      clause = cons(c, CDR(clause));
+      s = scm_cp_list(s, 0);
+      ASSYNT(!UNBNDP(s), CAR(clause) /* xorig */, s_clauses, s_case);
       DEFER_INTS;
-      unpaint(&CAR(clause));
+      unpaint(&s);
       ALLOW_INTS;
-      CAR(x) = clause;
 #else
-      ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
-#endif
-#ifndef RECKLESS
-      for (s = CAR(clause); NIMP(s); s = CDR(s))
-	ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case);
-      keys = append(cons2(CAR(clause), keys, EOL));
-#endif
+      ASSYNT(ilength(s) >= 0, CAR(clause) /* xorig */, s_clauses, s_case);
+#endif
+      action = m_seq(CDR(clause), env, ctxt);
+      for (; NIMP(s); s = CDR(s)) {
+	ASSYNT(FALSEP(memv(CAR(s), keys)), xorig, "duplicate key value", s_case);
+	if (NIMP(CAR(s)) && NUMP(CAR(s))) opt = 0;
+	keys = cons(CAR(s), keys);
+	actions = cons(action, actions);
+      }
+    }
+  }
+  key_expr = m_expr(key_expr, env, i_test);
+  if (opt && NIMP(*loc_atcase_aux) && !in_atcase_aux) {
+    SCM argv[3];
+    argv[0] = keys;
+    argv[1] = actions;
+    argv[2] = else_action;
+    in_atcase_aux = !0;
+    x = scm_cvapply(*loc_atcase_aux, 3L, argv);
+    in_atcase_aux = 0;		/* disabled after one error.  C'est la vie. */
+    if (NIMP(x) && CONSP(x)) {
+      s = CAR(x);
+      if (INUMP(s) && INUM(s) >= 0 && INUM(s) <= 2)
+	return cons2(MAKISYMVAL(IM_CASE, INUM(s)), key_expr, CDR(x));
     }
   }
-  return cons(IM_CASE, cdrx);
+  keys = cons(UNSPECIFIED, keys);
+  actions = cons(else_action, actions);
+  return cons2(IM_CASE, key_expr,
+	       cons2(vector(keys), vector(actions), EOL));
 }
 
-SCM m_cond(xorig, env)
-     SCM xorig, env;
+SCM m_cond(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx;
+  SCM s, clause, cdrx = scm_cp_list(CDR(xorig), 1), x = cdrx;
   int len = ilength(x);
   ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond);
   while(NIMP(x)) {
-    arg1 = CAR(x);
-    len = ilength(arg1);
-    ASSYNT(len >= 1, xorig, s_clauses, s_cond);
-    if TOPDENOTE_EQ(i_else, CAR(arg1), env) {
+    clause = scm_check_linum(CAR(x), 0L);
+    len = ilength(clause);
+    ASSYNT(len >= 1, CAR(x), s_clauses, s_cond);
+    if (TOPDENOTE_EQ(i_else, CAR(clause), env)) {
       ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, s_bad_else_clause, s_cond);
-      CAR(x) = cons(BOOL_T, CDR(arg1));
+      clause = cons(BOOL_T, m_seq(CDR(clause), env, ctxt));
     }
     else {
-      arg1 = CDR(arg1);
-      if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(arg1), env)) {
-	ASSYNT(3==len && NIMP(CAR(CDR(arg1))), xorig, "bad recipient", s_cond);
-	CAR(x) = cons2(CAR(CAR(x)), IM_ARROW, CDR(arg1));
+      s = CDR(clause);
+      if (len >= 2 && TOPDENOTE_EQ(i_arrow, CAR(s), env)) {
+	ASSYNT(3==len && NIMP(CAR(CDR(s))), clause, "bad recipient", s_cond);
+	clause = cons2(CAR(clause), IM_ARROW, CDR(s));
       }
+      else
+	clause = cons(CAR(clause), m_seq(s, env, ctxt));
     }
+    CAR(x) = clause;
     x = CDR(x);
   }
   return cons(IM_COND, cdrx);
 }
 
-static int varcheck(xorig, vars, op, what)
-     SCM xorig, vars;
-     char *op, *what;
+static int varcheck(vars, op, what)
+     SCM vars, op;
+     char *what;
 {
   SCM v1, vs;
+  char *opstr = ISYMCHARS(op) + 2;
   int argc = 0;
+  vars = scm_check_linum(vars, 0L);
   for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) {
     argc++;
 #ifndef RECKLESS
     v1 = CAR(vars);
     if (IMP(v1) || !IDENTP(v1))
-      badvar: wta(xorig, what, op);
+      badvar: scm_experr(v1, what, opstr);
     for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) {
-      if (v1==CAR(vs))
-	nonuniq: wta(xorig, "non-unique bindings", op);
+      if (v1==CAR(vs)) {
+	nonuniq:
+	what = "non-unique bindings";
+	goto badvar;
+      }
     }
     if (v1==vs) goto nonuniq;
 #endif
@@ -896,35 +1156,122 @@ static int varcheck(xorig, vars, op, what)
   ASRTGO(NIMP(vars) && IDENTP(vars), badvar);
   return argc > 2 ? 2 : argc;
 }
-SCM m_lambda(xorig, env)
-     SCM xorig, env;
+
+SCM m_lambda(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM x = CDR(xorig);
+  SCM x = CDR(xorig), formals;
+#ifdef CAUTIOUS
+  SCM name, linum;
+#endif
   int argc;
-  ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
-  argc = varcheck(xorig, CAR(x), s_lambda, s_formals);
+  ASSERT(ilength(x) > 1, x, s_body, s_lambda);
+  formals = CAR(x);
+  argc = varcheck(formals, IM_LAMBDA, s_formals);
+  formals = scm_check_linum(formals, 0L);
   if (argc > 3) argc = 3;
-  return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x),
-	       m_body(IM_LAMBDA, CDR(x), s_lambda));
+  x = CDR(x);
+  if (NIMP(CDR(x)) && NIMP(CAR(x)) && STRINGP(CAR(x))) {
+    env = scm_env_addprop(SCM_ENV_DOC, CAR(x), env);
+    x = CDR(x);
+  }
+#ifdef CAUTIOUS
+  if (NIMP(ctxt) && i_bind==CAR(ctxt)) {
+    ctxt = CDR(ctxt);
+    name = CAR(ctxt);
+  }
+  else
+    name = i_anon;
+  if (NIMP(scm_trace) && xorig==scm_check_linum(scm_trace, &linum))
+    if (!UNBNDP(linum)) env = EXTEND_ENV(linum, env);
+  env = scm_env_addprop(SCM_ENV_PROCNAME, name, env);
+#endif
+  env = EXTEND_ENV(formals, env);
+  return cons2(MAKISYMVAL(IM_LAMBDA, argc), env, m_body(x, env, EOL));
+}
+
+#ifdef MAC_INLINE
+static int env_depth()
+{
+  register int depth = 0;
+  register SCM env;
+  DEFER_INTS_EGC;
+  env = scm_env;
+  while(NIMP(env)) {
+    env = CDR(env);
+    depth++;
+  }
+  return depth;
 }
-SCM m_letstar(xorig, env)
+static void env_tail(depth)
+     int depth;
+{
+  register SCM env;
+  DEFER_INTS_EGC;
+  env = scm_env;
+  while(depth--) env = CDR(env);
+  scm_env = env;
+}
+/* FIXME update for split-env */
+SCM m_inline_lambda(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)) && IDENTP(CAR(arg1)), xorig, s_variable, s_letstar);
-    *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL);
-    varloc = &CDR(CDR(*varloc));
-    proc = CDR(proc);
+  SCM x = CDR(xorig);
+  SCM typ = (SCM)(tc16_macro | (MAC_INLINE << 16));
+  int depth = env_depth();
+  ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
+  ASSERT(ilength(CAR(x)) >= 0, xorig, s_formals, s_lambda);
+  varcheck(CAR(x), IM_LAMBDA, s_formals);
+  x = cons2(typ, MAKINUM((long)depth),
+	    cons(CAR(x), m_body(CDR(x), env)));
+  return cons2(IM_QUOTE, x, EOL);
+}
+#endif
+
+static char s_nullenv_p[] = "scm_nullenv_p";
+int scm_nullenv_p(env)
+     SCM env;
+{
+  SCM fr, e;
+  if (IMP(env)) return !0;
+  for (e = env; NIMP(e); e = CDR(e)) {
+    ASSERT(CONSP(e), e, s_badenv, s_nullenv_p);
+    fr = CAR(e);
+    if (IMP(fr)) {
+      if (NULLP(fr)) return 0;
+      if (INUMP(fr)) {      /* These frames are for meta-data, not bindings. */
+	e = CDR(e);
+	ASSERT(NIMP(e), env, s_badenv, s_nullenv_p);
+      }
+    } else return 0;
   }
-  x = cons(vars, CDR(x));
-  return cons2(IM_LETSTAR, CAR(x), m_body(IM_LETSTAR, CDR(x), s_letstar));
+  return !0;
+}
+static SCM m_letstar1(imm, vars, inits, body, env, ctxt)
+     SCM imm, vars, inits, body, env, ctxt;
+{
+  SCM init, bdgs = cons(env, EOL); /* initial env is for debug printing. */
+  SCM *loc = &CDR(bdgs);
+  while (NIMP(vars)) {
+    init = m_binding(CAR(vars), CAR(inits), env, ctxt);
+    env = EXTEND_ENV(CAR(vars), env);
+    *loc = cons2(init, env, EOL);
+    loc = &CDR(CDR(*loc));
+    vars = CDR(vars);
+    inits = CDR(inits);
+  }
+  return cons2(IM_LETSTAR, bdgs, m_body(body, env, ctxt));
+}
+
+SCM m_letstar(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM vars, inits;
+  SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits);
+  /* IM_LETSTAR must bind at least one variable. */
+  if (IMP(vars))
+    return m_let_null(body, env, ctxt);
+  return m_letstar1(IM_LETSTAR, vars, inits, body, env, ctxt);
 }
 
 /* DO gets the most radically altered syntax
@@ -940,33 +1287,40 @@ SCM m_letstar(xorig, env)
    (<body>)
    <stepn> ... <step2> <step1>) ;; missing steps replaced by var
    */
-SCM m_do(xorig, env)
-     SCM xorig, env;
+SCM m_do(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM x = CDR(xorig), arg1, proc;
+  SCM x = CDR(xorig), bdg, bdgs, test, body;
   SCM vars = IM_DO, inits = EOL, steps = EOL;
   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);
-    /* vars reversed here, inits and steps reversed at evaluation */
-    vars = cons(CAR(arg1), vars); /* variable */
-    arg1 = CDR(arg1);
-    inits = cons(CAR(arg1), inits);
-    arg1 = CDR(arg1);
-    steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps);
-    proc = CDR(proc);
+  bdgs = scm_check_linum(CAR(x), 0L);
+  ASSYNT(ilength(bdgs) >= 0, CAR(x), s_bindings, s_do);
+  while NIMP(bdgs) {
+    bdg = scm_check_linum(CAR(bdgs), 0L);
+    len = ilength(bdg);
+    ASSYNT(2==len || 3==len, CAR(bdgs), s_bindings, s_do);
+    vars = cons(CAR(bdg), vars); /* variable */
+    bdg = CDR(bdg);
+    inits = cons(CAR(bdg), inits);
+    bdg = CDR(bdg);
+    steps = cons(IMP(bdg) ? CAR(vars) : CAR(bdg), steps);
+    bdgs = CDR(bdgs);
   }
+  if (IMP(vars)) vars = EOL;
+  inits = m_bindings(vars, inits, env, ctxt);
+  env = EXTEND_ENV(vars, env);
+  steps = m_bindings(vars, steps, env, ctxt);
   x = CDR(x);
-  ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
+  test = scm_check_linum(CAR(x), 0L);
+  ASSYNT(ilength(test) >= 1, CAR(x), s_test, s_do);
+  test = m_seq(test, env, ctxt);
+  if (IMP(CDR(test))) test = cons(CAR(test), list_unspecified);
   ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do);
-  varcheck(xorig, vars, s_do, s_variable);
-  x = cons2(CAR(x), CDR(x), steps);
-  x = cons2(vars, inits, x);
+  varcheck(vars, IM_DO, s_variable);
+  body = scm_check_linum(CDR(x), 0L);
+  x = cons2(test, m_seq(body, env, i_side_effect), steps);
+  x = cons2(env, inits, x);
   return cons(IM_DO, x);
 }
 
@@ -1000,8 +1354,8 @@ static SCM iqq(form)
   return cons(iqq(CAR(form)), iqq(CDR(form)));
 }
 
-static SCM m_iqq(form, depth, env)
-     SCM form, env;
+static SCM m_iqq(form, depth, env, ctxt)
+     SCM form, env, ctxt;
      int depth;
 {
   SCM tmp;
@@ -1012,7 +1366,7 @@ static SCM m_iqq(form, depth, env)
     SCM *data = VELTS(form);
     tmp = EOL;
     for(;--i >= 0;) tmp = cons(data[i], tmp);
-    tmp = m_iqq(tmp, depth, env);
+    tmp = m_iqq(tmp, depth, env, ctxt);
     for(i = 0; i < LENGTH(form); i++) {
       data[i] = CAR(tmp);
       tmp = CDR(tmp);
@@ -1025,7 +1379,8 @@ static SCM m_iqq(form, depth, env)
 #endif
     return form;
   }
-  tmp = CAR(form);
+ form = scm_check_linum(form, 0L); /* needed? */
+  tmp = scm_check_linum(CAR(form), 0L);
   if NIMP(tmp) {
     if IDENTP(tmp) {
 #ifdef MACRO
@@ -1033,49 +1388,46 @@ static SCM m_iqq(form, depth, env)
 #endif
       if (i_quasiquote==tmp && TOPLEVELP(CAR(form), env)) {
 	depth++;
-	if (0==depth) CAR(form) = IM_QUASIQUOTE;
+	if (0==depth) tmp = IM_QUASIQUOTE;
 	goto label;
       }
-      if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) {
+      else if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) {
 	--depth;
-	if (0==depth) CAR(form) = IM_UNQUOTE;
+	if (0==depth) tmp = IM_UNQUOTE;
       label:
-	tmp = CDR(form);
-	ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)),
-	       tmp, ARG1, s_quasiquote);
-	if (0!=depth) CAR(tmp) = m_iqq(CAR(tmp), depth, env);
-	return form;
+	form = CDR(form);
+	ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
+	       form, ARG1, s_quasiquote);
+	if (0!=depth)
+	  form = cons(m_iqq(CAR(form), depth, env, ctxt), EOL);
+	return cons(tmp, form);
       }
     }
     else {
-      if TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env) {
-	if (0==--edepth) {
-	  CAR(tmp) = IM_UQ_SPLICING;
-	  CDR(form) = m_iqq(CDR(form), depth, env);
-	  return form;
-	}
+      if (TOPDENOTE_EQ(i_uq_splicing, CAR(tmp), env)) {
+	if (0==--edepth)
+	  return cons(cons(IM_UQ_SPLICING, CDR(tmp)),
+		      m_iqq(CDR(form), depth, env, ctxt));
       }
-      CAR(form) = m_iqq(tmp, edepth, env);
+      tmp = m_iqq(tmp, edepth, env, ctxt);
     }
   }
-  CAR(form) = tmp;
-  CDR(form) = m_iqq(CDR(form), depth, env);
-  return form;
+  return cons(tmp, m_iqq(CDR(form), depth, env, ctxt));
 }
-SCM m_quasiquote(xorig, env)
-     SCM xorig, env;
+SCM m_quasiquote(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   SCM x = CDR(xorig);
   ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
-  x = m_iqq(copytree(x), 1, env);
+  x = m_iqq(x, 1, env, ctxt);
   return cons(IM_QUASIQUOTE, x);
 }
 
-SCM m_delay(xorig, env)
-     SCM xorig, env;
+SCM m_delay(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
-  return cons2(IM_DELAY, EOL, CDR(xorig));
+  return cons2(IM_DELAY, EXTEND_ENV(EOL, env), CDR(xorig));
 }
 
 static int built_inp(name, x)
@@ -1092,229 +1444,450 @@ static int built_inp(name, x)
   return 0;
 }
 
-SCM m_define(x, env)
-     SCM x, env;
+static void checked_define(name, val, what)
+     SCM name, val;
+     char *what;
 {
-  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(TOPRENAME(i_lambda), CDR(proc), x), EOL);
-    proc = CAR(proc);
-  }
-  ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
-  ASSYNT(1==ilength(x), arg1, s_expression, s_define);
-  if (NIMP(env) && ENVP(env)) {
-    DEFER_INTS_EGC;
-    env = CDR(env);
-  }
-  if NULLP(env) {
-    x = evalcar(x);
+  SCM old, vcell;
 #ifdef MACRO
-    while M_IDENTP(proc) {
-      ASSYNT(IMP(IDENT_MARK(proc)), proc, s_escaped, s_define);
-      proc = IDENT_PARENT(proc);
-    }
+  while (M_IDENTP(name)) {
+    ASSERT(IMP(IDENT_ENV(name)), name, s_escaped, what);
+    name = IDENT_PARENT(name);
+  }
 #endif
-    arg1 = sym2vcell(proc);
+  vcell = sym2vcell(name);
+  old = CDR(vcell);
 #ifndef RECKLESS
-    if (2 <= verbose &&
-	built_inp(proc, CDR(arg1))
-	&& (CDR(arg1) != x))
-      scm_warn("redefining built-in ", CHARS(proc));
-    else
-#endif
-    if (5 <= verbose && UNDEFINED != CDR(arg1))
-      scm_warn("redefining ", CHARS(proc));
-    CDR(arg1) = x;
-#ifdef SICP
-    return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL);
-#else
-    return UNSPECIFIED;
-#endif
+    if ('@'==CHARS(name)[0] && UNDEFINED != old)
+      scm_warn("redefining internal name ", "", name);
+    if (KEYWORDP(old)) {
+      if (1 <= verbose && built_inp(name, KEYWORD_MACRO(old)))
+	scm_warn("redefining built-in syntax ", "", name);
+      else if (3 <= verbose)
+	scm_warn("redefining syntax ", "", name);
+    }
+    else if (2 <= verbose && built_inp(name, old) && (old != val))
+      scm_warn("redefining built-in ", "", name);
+    else if (5 <= verbose && UNDEFINED != old)
+      scm_warn("redefining ", "", name);
+#endif
+    CDR(vcell) = val;
+}
+
+SCM m_define(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM name, linum, x = CDR(xorig);
+  ASSYNT(ilength(x) >= 2, xorig, s_expression, s_define);
+  name = CAR(x); x = CDR(x);
+  while (NIMP(name) && CONSP(name)) { /* nested define syntax */
+    name = scm_check_linum(name, &linum);
+    x = scm_add_linum(linum, cons2(TOPRENAME(i_lambda), CDR(name), x));
+    x = cons(x, EOL);
+    name = CAR(name);
   }
-  return cons2(IM_DEFINE, proc, x);
+  ASSYNT(NIMP(name) && IDENTP(name), xorig, s_variable, s_define);
+  ASSYNT(1==ilength(x), xorig, s_expression, s_define);
+  return cons2(IM_DEFINE, name, x);
 }
 /* end of acros */
 
-static SCM m_letrec1(op, imm, xorig, env)
-     SCM op, imm, xorig, env;
+/* returns body, x should be cdr of a LET, LET*, or LETREC form.
+   vars and inits are returned in the original order. */
+static SCM m_parse_let(imm, xorig, x, vars, inits)
+     SCM imm, xorig, x, *vars, *inits;
 {
-  SCM cdrx = CDR(xorig);	/* locally mutable version of form */
+  SCM clause, bdgs, *varloc = vars, *initloc = inits;
+  int len = ilength(x);
+#ifdef MACRO
+  char *what = CHARS(ident2sym(CAR(xorig)));
+#else
   char *what = CHARS(CAR(xorig));
-  SCM x = cdrx, proc, arg1;	/* structure traversers */
-  SCM vars = imm, inits = EOL;
-  /*  ASRTSYNTAX(ilength(x) >= 2, s_body); */
-  proc = CAR(x);
-  ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
-  do {
-    arg1 = CAR(proc);
-    ASRTSYNTAX(2==ilength(arg1), s_bindings);
-    vars = cons(CAR(arg1), vars);
-    inits = cons(CAR(CDR(arg1)), inits);
-  } while NIMP(proc = CDR(proc));
-  varcheck(xorig, vars, what, s_variable);
-  return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what)));
+#endif
+  *varloc = imm;
+  *initloc = EOL;
+  ASSYNT(len >= 2, UNDEFINED, s_body, what);
+  bdgs = scm_check_linum(CAR(x), 0L);
+  ASSYNT(ilength(bdgs) >= 0, bdgs, s_bindings, what);
+  while NIMP(bdgs) {
+    clause = scm_check_linum(CAR(bdgs), 0L);
+    ASSYNT(2==ilength(clause), clause, s_bindings, what);
+    ASSYNT(NIMP(CAR(clause)) && IDENTP(CAR(clause)), CAR(clause),
+	   s_variable, what);
+    *varloc = cons(CAR(clause), imm);
+    varloc = &CDR(*varloc);
+    *initloc = cons(CAR(CDR(clause)), EOL);
+    initloc = &CDR(*initloc);
+    bdgs = CDR(bdgs);
+  }
+  x = CDR(x);
+  ASSYNT(ilength(x)>0, scm_wrapcode(x, EOL) /* xorig */, s_body, what);
+  if (IMP(*vars)) *vars = EOL;
+  return x;
 }
 
-SCM m_letrec(xorig, env)
-     SCM xorig, env;
+static SCM m_let_null(body, env, ctxt)
+     SCM body, env, ctxt;
 {
-  SCM x = CDR(xorig);
-  ASSYNT(ilength(x) >= 2, xorig, s_body, s_letrec);
-  if NULLP(CAR(x))   /* null binding, let* faster */
-    return m_letstar(cons2(CAR(xorig), EOL,
-			   m_body(IM_LETREC, CDR(x), s_letrec)),
-		     env);
-  return m_letrec1(IM_LETREC, IM_LETREC, xorig, env);
+  SCM x;
+  if (scm_nullenv_p(env)) {
+    env = EXTEND_ENV(EOL, env);
+    return cons2(IM_LET, env, cons(EOL, m_body(body, env, ctxt)));
+  }
+  x = m_body(body, env, ctxt);
+  return NULLP(CDR(x)) ? CAR(x) : cons(IM_BEGIN, x);
 }
 
-SCM m_let(xorig, env)
-     SCM xorig, env;
+static SCM m_letrec1(imm, xorig, env, ctxt)
+     SCM imm, xorig, env, ctxt;
+{
+  SCM vars, inits, op = MAKSPCSYM2(IM_LETREC, imm);
+  SCM body = m_parse_let(imm, xorig, CDR(xorig), &vars, &inits);
+  if (IMP(vars)) return m_let_null(body, env, ctxt);
+  varcheck(vars, imm, s_variable);
+  env = EXTEND_ENV(vars, env);
+  inits = m_bindings(vars, inits, env, ctxt);
+  return cons2(op, env, cons(inits, m_body(body, env, ctxt)));
+}
+
+SCM m_letrec(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM cdrx = CDR(xorig);	/* locally mutable version of form */
-  SCM x = cdrx, proc, arg1, name; /* structure traversers */
-  SCM vars = IM_LET, inits = EOL, *varloc = &vars, *initloc = &inits;
+  return m_letrec1(IM_LETREC, xorig, env, ctxt);
+}
 
+SCM m_let(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM proc, body, vars, inits, x = CDR(xorig);
   ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
   proc = CAR(x);
-  if (NULLP(proc)		/* null or single binding, let* is faster */
-      || (NIMP(proc) && CONSP(proc)
-	  && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
-    return m_letstar(cons2(CAR(xorig), proc, m_body(IM_LET, CDR(x), s_let)),
-		     env);
-  ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
-  if CONSP(proc)		/* plain let, proc is <bindings> */
-    return m_letrec1(IM_LET, IM_LET, xorig, env);
-  if (!IDENTP(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)) && IDENTP(CAR(arg1)), xorig, s_variable, s_let);
-    *varloc = cons(CAR(arg1), IM_LET);
-    varloc = &CDR(*varloc);
-    *initloc = cons(CAR(CDR(arg1)), EOL);
-    initloc = &CDR(*initloc);
-    proc = CDR(proc);
+  if (NIMP(proc) && IDENTP(proc)) { /* named let, build equiv letrec */
+    x = CDR(x);
+    body = m_parse_let(IM_LET, xorig, x, &vars, &inits);
+    x = cons2(TOPRENAME(i_lambda), vars, body);
+    x = cons2(i_let, cons(cons2(proc, x, EOL), EOL), cons(proc, EOL));
+    return cons(m_letrec1(IM_LET, x, env, ctxt), inits);
   }
-  proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let));
-  proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL));
-  return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits);
+				/* vanilla let */
+  body = m_parse_let(IM_LET, xorig, x, &vars, &inits);
+  varcheck(vars, IM_LET, s_variable);
+  if (IMP(vars))
+    return m_let_null(body, env, ctxt);
+  if (IMP(CDR(vars)))		/* single binding, let* is faster */
+    return m_letstar1(IM_LET, vars, inits, body, env, ctxt);
+  inits = m_bindings(vars, inits, env, ctxt);
+  env = EXTEND_ENV(vars, env);
+  return cons2(IM_LET, env, cons(inits, m_body(body, env, ctxt)));
 }
 
 #define s_atapply (ISYMCHARS(IM_APPLY)+1)
 
-SCM m_apply(xorig, env)
-     SCM xorig, env;
+SCM m_apply(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply);
   return cons(IM_APPLY, CDR(xorig));
 }
 
-static SCM m_expand_body(xorig)
-     SCM xorig;
+static SCM m_body(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM form, x = CDR(xorig), defs = EOL;
+  SCM form, denv = env, x = xorig, defs = EOL;
   char *what = ISYMCHARS(CAR(xorig)) + 2;
+  ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
   while NIMP(x) {
-    form = CAR(x);
+    form = scm_check_linum(CAR(x), 0L);
     if (IMP(form) || NCONSP(form)) break;
     if IMP(CAR(form)) break;
     if (! IDENTP(CAR(form))) break;
-    form = macroexp1(form, defs);
+    form = macroexp1(CAR(x), denv, i_check_defines, 1);
     if (IM_DEFINE==CAR(form)) {
       defs = cons(CDR(form), defs);
       x = CDR(x);
     }
+    else if (IM_BEGIN==CAR(form)) {
+      form = CDR(form);
+      x = CDR(x);
+      if (IMP(x))
+	x = form;
+      else if (UNSPECIFIED==CAR(form) && IMP(CDR(form)))
+	;
+      else
+	x = append(cons2(form, x, EOL));
+    }
     else if NIMP(defs) {
       break;
     }
-    else if (IM_BEGIN==CAR(form)) {
-      x = append(cons2(CDR(form), CDR(x), EOL));
-    }
     else {
+      /* Doesn't work when m_body recursively called
+	 x = cons(form, m_seq(CDR(x), env, ctxt)); */
       x = cons(form, CDR(x));
       break;
     }
   }
-  ASSYNT(NIMP(x), CDR(xorig), s_body, what);
-  if NIMP(defs)
-    x = cons(m_letrec1(IM_LETREC, IM_DEFINE, cons2(i_define, defs, x),
-		       wrapenv())
-	     , EOL);
-  DEFER_INTS;
-  CAR(xorig) = CAR(x);
-  CDR(xorig) = CDR(x);
-  ALLOW_INTS;
-  return xorig;
+#ifdef CAUTIOUS
+  ASSYNT(ilength(x) > 0, x, s_body, what);
+#else
+  ASSYNT(ilength(x) > 0, CDR(xorig), s_body, what);
+#endif
+  if (IMP(defs)) return x;
+  return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL);
 }
 
-static SCM macroexp1(x, defs)
-     SCM x, defs;
+static SCM m_binding(name, value, env, ctxt)
+     SCM name, value, env, ctxt;
 {
-  SCM res = UNDEFINED, proc = CAR(x);
-  int argc;
-  ASRTGO(IDENTP(proc), badfun);
+  if (IMP(value) || NCONSP(value)) return value;
+  ctxt = cons2(i_bind, name, EOL);
+  return macroexp1(value, env, ctxt, 2);
+}
+static SCM m_bindings(names, values, env, ctxt)
+     SCM names, values, env, ctxt;
+{
+  SCM x;
+  for (x = values; NIMP(x); x = CDR(x)) {
+    CAR(x) = m_binding(CAR(names), CAR(x), env, ctxt);
+    names = CDR(names);
+  }
+  return values;
+}
+static SCM m_seq(x, env, ctxt)
+     SCM x, env, ctxt;
+{
+  SCM form, ret = EOL, *loc = &ret;
+  for (; NIMP(x); x = CDR(x)) {
+    form = CAR(x);
+    if (NIMP(form) && CONSP(form)) {
+      form = macroexp1(form, env, IMP(CDR(x)) ? ctxt : i_side_effect, 2);
+      if (NIMP(form) && IM_BEGIN==CAR(form)) {
+	x = append(cons2(form, CDR(x), EOL));
+	continue;
+      }
+    }
+    *loc = cons(form, EOL);
+    loc = &CDR(*loc);
+  }
+  return ret;
+}
+static SCM m_expr(x, env, ctxt)
+     SCM x, env, ctxt;
+{
+  if (NIMP(x) && CONSP(x)) {
+    x = macroexp1(x, env, ctxt, 2);
+    if (NIMP(x) && IM_BEGIN==CAR(x))
+      x = cons(IM_BEGIN, m_seq(CDR(x), env, ctxt));
+  }
+  return x;
+}
+
+SCM scm_check_linum(x, linum)
+     SCM x, *linum;
+{
+  SCM lin = UNDEFINED;
+  if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) {
+    lin = CAR(x);
+    x = CDR(x);
+  }
+  if (linum) *linum = lin;
+  return x;
+}
+SCM scm_add_linum(linum, x)
+     SCM x, linum;
+{
+  if (UNBNDP(linum)) return x;
+  if (NIMP(x) && CONSP(x) && SCM_LINUMP(CAR(x))) return x;
+  return cons(linum, x);
+}
+
+/*
+   mode values:
+     0 expand non-primitive macros only
+     1 check for defines, expand non-primitive macros and DEFINE and BEGIN
+     2 expand all macros
+     3 executing: all macros must be expanded, all values must be defined and
+        will be memoized, the form may be destructively altered.
+
+*/
+static SCM macroexp1(xorig, env, ctxt, mode)
+     SCM xorig, env, ctxt;
+     int mode;
+{
+  SCM x = xorig, linum, proc = UNDEFINED, res = UNDEFINED;
+#ifndef RECKLESS
+  SCM trace = scm_trace, trace_env = scm_trace_env;
+  long argc;
+  char *what = s_wtap;
+  MACROEXP_TRACE(xorig, env);
+#endif
+  x = scm_check_linum(xorig, &linum);
+  if (IMP(x) || NCONSP(x)) {	/* Happens for unquoted vectors. */
+    if (NIMP(x))
+      x = evalatomcar(cons(x, EOL), 0);
+    x = cons2(IM_QUOTE, x, EOL);
+    goto retx;
+  }
+  else if (IDENTP(x)) {		/* Happens for @macroexpand1 */
+    proc = x;
+    x = cons(proc, EOL);
+  }
+  else
+    proc = CAR(x);
+  ASRTGO(NIMP(proc), errout);
+  if (CONSP(proc)) {
+    if (mode < 3) {
+      x = xorig;
+      goto retx;
+    }
+    if (NIMP(CAR(proc)))
+      proc = macroexp1(cons(CAR(proc), CDR(proc)), env, i_procedure, mode);
+    if ((127L & IM_LAMBDA)==(127L & CAR(proc))) {
+      SCM nenv = CAR(CDR(proc));
+      SCM formals = SCM_ENV_FORMALS(nenv);
+#ifndef RECKLESS
+      if (badargsp(formals, CDR(x))) {
+	what = (char *)WNA;
+	proc = CAR(x);
+	goto errout;
+      }
+#endif
+      res = CDR(x);
+      if (ilength(formals) >= 0) {
+	x = cons2(IM_LET, nenv, cons(res, CDR(CDR(proc))));
+	goto retx;
+      }
+    }
+    x = cons2(IM_FUNCALL, proc, CDR(x));
+    goto retx;
+  }
+  ASRTGO(IDENTP(proc), errout);
  macro_tail:
-  res = CAR(x);
-  proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0);
-  if (NIMP(proc) && MACROP(proc)) {
-    CAR(x) = res;
-    res = cons2(x, wrapenv(), EOL);
-    switch ((int)(CAR(proc)>>16) & 0x7f) {
-    case 2: case 6:		/* mmacro */
-      if (IMP(defs)) {
-	res = apply(CDR(proc), res, EOL);
-	if (ilength(res) <= 0)
-	  res = cons2(IM_BEGIN, res, EOL);
-	DEFER_INTS;
-	CAR(x) = CAR(res);
-	CDR(x) = CDR(res);
-	ALLOW_INTS;
-	break;
+  res = proc;			/* For nicer error message. */
+  if (mode >= 3) {
+    x = cons(CAR(x), CDR(x));
+    proc = scm_lookupval(x, !0);
+  }
+  else {
+    proc = scm_env_lookup(proc, env);
+    if (IMP(proc)) {		/* local binding */
+      x = scm_add_linum(linum, x);
+      goto retx;
+    }
+    if (CONSP(proc))		/* local syntax binding. */
+      proc = CDR(proc);
+    else if (SYMBOLP(proc))	/* global variable */
+      proc = CDR(sym2vcell(proc));
+  }
+  if (KEYWORDP(proc)) {
+    SCM argv[3];
+    long argc = 2;
+    proc = KEYWORD_MACRO(proc);
+    argv[0] = x;
+    argv[1] = env;
+    argv[2] = ctxt;
+    switch (MAC_TYPE(proc)) {
+    case MAC_MACRO: case MAC_MACRO | MAC_PRIMITIVE:
+    case MAC_ACRO: case MAC_ACRO | MAC_PRIMITIVE:
+	/* This means non-memoizing macros can't expand into internal defines.
+	   That's ok with me. */
+      if (mode > 1)
+	x = cons2(IM_ACRO_CALL, CAR(x), CDR(x));
+      goto retx;
+    case MAC_MMACRO | MAC_PRIMITIVE:
+    case MAC_IDMACRO | MAC_PRIMITIVE:
+      if (0==mode ||
+          (1==mode && f_define != CDR(proc) && f_begin != CDR(proc))) {
+        x = scm_add_linum(linum, x);
+        goto retx;
       }
-     /* else fall through */
-    case 1: case 5:		/* macro */
-      res = apply(CDR(proc), res, EOL);
-      x =  NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
+      argv[2] = ctxt;
+      argc = 3;
+				/* fall through */
+    case MAC_MMACRO:
+    case MAC_IDMACRO:
+      argv[0] = x;
+      argv[1] = env;
+      x = scm_cvapply(CDR(proc), argc, argv);
+      if (ilength(x) <= 0)
+	x = cons2((0==mode ? TOPRENAME(i_begin): IM_BEGIN), x, EOL);
       break;
-    case 0: case 4:		/* acro */
-      res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED;
-      return cons2(IM_QUOTE, res, EOL);
+#ifdef MAC_INLINE		/* FIXME this is broken */
+    case MAC_INLINE:
+      {
+	int depth = env_depth();
+	res = CDR(proc);
+	depth -= INUM(CAR(res));
+	res = CDR(res);
+	x = cons2(MAKISYMVAL(IM_LET, depth),
+		     CAR(res), cons(CDR(x), CDR(res)));
+	break;
+      }
+#endif
+    }
+    MACROEXP_TRACE(xorig, env);
+    x = scm_check_linum(x, 0L);
+    if (NIMP(CAR(x)) && IDENTP(CAR(x))) {
+      proc = CAR(x);
+      goto macro_tail;
     }
-    if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
 #ifndef RECKLESS
-    if (UNBNDP(defs) && IM_DEFINE==CAR(x))
-      everr(x, wrapenv(), i_define, "Bad placement", "");
+    if (IM_DEFINE==CAR(x) && (mode != 1) && !scm_nullenv_p(env)) {
+      what = s_placement;
+      proc = res = i_define;
+    errout:
+      if (!UNBNDP(res))
+	CAR(x) = res; /* FIXME may not be right for @macroexpand1 */
+      if (UNBNDP(proc) && NIMP(x) && CONSP(x))
+	proc = CAR(x);
+      scm_experr(proc, what, "");
+    }
 #endif
-    return x;
   }
+  else {		/* not a macro expression, car is identifier */
+    if (0 == mode)
+      x = BOOL_F;
+    else if (mode <=2 )
+      x = scm_add_linum(linum, x);
 #ifndef RECKLESS
-  if (IMP(defs)) {
-    if (! scm_arity_check(proc, ilength(CDR(x)), (char *)0)) {
-    badfun:
-      if (!UNBNDP(res)) CAR(x) = res;
-      everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
-	    UNBNDP(proc) ? s_unbnd :
-	          (FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA),
-	    "");
+    else if (mode >= 3) {
+      argc = ilength(CDR(x));
+      if (! scm_arity_check(proc, argc, (char *)0)) {
+	if (argc < 0) {
+	  what = s_expr;
+	  proc = x;
+	}
+	else
+	  what = FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA;
+	goto errout;
+      }
+      for (proc = CDR(x); NIMP(proc); proc = CDR(proc)) {
+	res = CAR(proc);
+	if (NIMP(res)) {
+	  if (IDENTP(res))
+	    scm_lookupval(proc, !0);
+	  else if (CONSP(res))
+	    macroexp1(res, env, i_argument, mode);
+	}
+      }
     }
+#endif
   }
-#endif /* ndef RECKLESS */
+ retx:
+  if (mode >= 3 && x != xorig) {
+    DEFER_INTS;
+    CAR(xorig) = CAR(x);
+    CDR(xorig) = CDR(x);
+    x = xorig;
+    ALLOW_INTS;
+  }
+  MACROEXP_TRACE(trace, trace_env); /* restore */
   return x;
 }
 
 #ifndef RECKLESS
-int badargsp(proc, args)
-     SCM proc, args;
+int badargsp(formals, args)
+     SCM formals, args;
 {
-  SCM formals = CAR(CODE(proc));
   while NIMP(formals) {
     if NCONSP(formals) return 0;
     if IMP(args) return 1;
@@ -1323,24 +1896,23 @@ int badargsp(proc, args)
   }
   return NNULLP(args) ? 1 : 0;
 }
-/* If what is null, signals error instead of returning false. */
+/* If what is non-null, signals error instead of returning false. */
 int scm_arity_check(proc, argc, what)
      SCM proc;
      long argc;
      char *what;
 {
   SCM p = proc;
-  if (IMP(p))
-    return 0;
+  if (IMP(p) || argc < 0) goto badproc;
  cclo_tail:
   switch TYP7(p) {
   default:
   badproc:
-    if (what) wta(proc, (char *)ARG1, what);
+    if (what) wta(proc, s_wtap, what);
+    return 0;
+  wrongnumargs:
+    if (what) wta(proc, (char *)WNA, what);
     return 0;
- wrongnumargs:
-  if (what) wta(proc, (char *)WNA, what);
-  return 0;
   case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0;
   case tc7_cxr:
   case tc7_contin:
@@ -1355,9 +1927,12 @@ int scm_arity_check(proc, argc, what)
   case tc7_lsubr_2: ASRTGO(2<=argc, wrongnumargs) return !0;
   case tc7_specfun:
     switch TYP16(proc) {
-    case tc16_apply: ASRTGO(2<=argc, wrongnumargs) return !0;
+    default: wta(proc, "internal error", "scm_arity_check");
+    case tc16_apply: ASRTGO(2<=argc, wrongnumargs); return !0;
     case tc16_call_cc:
-    case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0;
+    case tc16_eval: ASRTGO(1==argc, wrongnumargs); /* fall through */
+    case tc16_values: return !0;
+    case tc16_call_wv: ASRTGO(2==argc, wrongnumargs); return !0;
 # ifdef CCLO
     case tc16_cclo:
       p = CCLO_SUBR(p);
@@ -1367,50 +1942,82 @@ int scm_arity_check(proc, argc, what)
     }
   case tcs_closures:
     {
-      SCM formals = CAR(CODE(p));
+      SCM formals = SCM_ENV_FORMALS(CAR(CODE(p)));
       while (argc--) {
-	if IMP(formals) goto wrongnumargs;
+	ASRTGO(NIMP(formals), wrongnumargs);
 	if (CONSP(formals))
 	  formals = CDR(formals);
 	else
 	  return !0;
       }
       ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs);
+      return !0;
     }
   }
 }
 #endif
 
-char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
+char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "@eval";
 char s_call_cc[] = "call-with-current-continuation"; /* s_apply[] = "apply"; */
 
-static SCM wrapenv()
+/* static int checking_defines_p(ctxt) SCM ctxt; */
+/* {return (NIMP(ctxt) && i_check_defines==CAR(ctxt));} */
+/* static SCM wrapenv() */
+/* {register SCM z; */
+/*  DEFER_INTS_EGC; if NULLP(scm_env) return EOL; */
+/*  NEWCELL(z); DEFER_INTS_EGC; */
+/*  if (NIMP(scm_env) && ENVP(scm_env)) return scm_env; */
+/*  CDR(z) = scm_env; CAR(z) = tc16_env; */
+/*  EGC_ROOT(z); return z;} */
+
+SCM scm_current_env()
 {
-  register SCM z;
-  NEWCELL(z);
-  DEFER_INTS_EGC;
-  if (NIMP(scm_env) && ENVP(scm_env))
-    return scm_env;
-  CDR(z) = scm_env;
-  CAR(z) = tc16_env;
-  EGC_ROOT(z);
-  return z;
+  if (NFALSEP(scm_estk))
+    return STATIC_ENV;
+  return EOL;
 }
 
-SCM ceval(x, env)
-     SCM x, env;
+SCM ceval(x, static_env, env)
+     SCM x, static_env, env;
 {
   ENV_PUSH;
 #ifdef CAUTIOUS
-  scm_trace = UNSPECIFIED;
+  scm_trace = BOOL_F;
 #endif
   TRACE(x);
+  STATIC_ENV = static_env;
   scm_env = env;
   x = ceval_1(x);
   ENV_POP;
   ALLOW_INTS_EGC;
   return x;
 }
+SCM scm_eval_values(x, env, valenv)
+     SCM x, env, valenv;
+{
+  SCM res;
+  ENV_PUSH;
+#ifdef CAUTIOUS
+  scm_trace = BOOL_F;
+#endif
+  TRACE(x);
+  STATIC_ENV = env;
+  scm_env = valenv;
+  scm_env_tmp = IM_VALUES_TOKEN;
+  if (NIMP(x)) x = ceval_1(x);
+  DEFER_INTS_EGC;
+  if (IM_VALUES_TOKEN==scm_env_tmp) {
+    if (UNBNDP(x))
+      res = EOL;
+    else
+      res = cons(x, EOL);
+  }
+  else
+    res = cons2(x, CAR(scm_env_tmp), CDR(scm_env_tmp));
+  ENV_POP;
+  ALLOW_INTS_EGC;
+  return res;
+}
 
 static SCM ceval_1(x)
      SCM x;
@@ -1433,7 +2040,7 @@ static SCM ceval_1(x)
   switch TYP7(x) {
   case tcs_symbols:
     /* only happens when called at top level */
-    x = *lookupcar(cons(x, UNDEFINED), LOOKUP_UNDEFP);
+    x = evalatomcar(cons(x, UNDEFINED), !0);
     goto retx;
   case (127 & IM_AND):
     x = CDR(x);
@@ -1448,14 +2055,7 @@ static SCM ceval_1(x)
  begin:
     t.arg1 = x;
     while(NNULLP(t.arg1 = CDR(t.arg1))) {
-      if IMP(CAR(x)) {
-	if ISYMP(CAR(x)) {
-	  x = m_expand_body(x);
-	  goto begin;
-	}
-      }
-      else
-	ceval_1(CAR(x));
+      if (NIMP(CAR(x))) ceval_1(CAR(x));
       x = t.arg1;
     }
  carloop:			/* eval car of last form in list */
@@ -1464,7 +2064,7 @@ static SCM ceval_1(x)
       x = IMP(x) ? EVALIMP(x) : I_VAL(x);
     }
     else if ATOMP(CAR(x))
-      x = evalatomcar(x);
+      x = evalatomcar(x, 0);
     else {
       x = CAR(x);
       goto loop;			/* tail recurse */
@@ -1475,32 +2075,8 @@ static SCM ceval_1(x)
     return x;
 
   case (127 & IM_CASE):
-    x = CDR(x);
-    t.arg1 = EVALCAR(x);
-#ifndef INUMS_ONLY
-    arg2 = (SCM)(IMP(t.arg1) || !NUMP(t.arg1));
-#endif
-    while(NIMP(x = CDR(x))) {
-      proc = CAR(x);
-      if (IM_ELSE==CAR(proc)) {
-	x = CDR(proc);
-	goto begin;
-      }
-      proc = CAR(proc);
-      while NIMP(proc) {
-	if (
-#ifndef INUMS_ONLY
-	    arg2 ? NFALSEP(eqv(CAR(proc), t.arg1)) :
-#endif
-	    (CAR(proc)==t.arg1)) {
-	  x = CDR(CAR(x));
-	  goto begin;
-	}
-	proc = CDR(proc);
-      }
-    }
-    x = UNSPECIFIED;
-    goto retx;
+    x = scm_case_selector(x);
+    goto begin;
   case (127 & IM_COND):
     while(NIMP(x = CDR(x))) {
       proc = CAR(x);
@@ -1525,7 +2101,8 @@ static SCM ceval_1(x)
     TRACE(x);
     x = CDR(x);
     ecache_evalx(CAR(CDR(x)));	/* inits */
-    EXTEND_ENV(CAR(x));
+    STATIC_ENV = CAR(x);
+    EXTEND_VALENV;
     x = CDR(CDR(x));
     while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
       for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
@@ -1533,9 +2110,8 @@ static SCM ceval_1(x)
 	SIDEVAL_1(t.arg1);
       }
       ecache_evalx(CDR(CDR(x))); /* steps */
-      t.arg1 = CAR(CAR(scm_env));
       scm_env = CDR(scm_env);
-      EXTEND_ENV(t.arg1);
+      EXTEND_VALENV;
     }
     x = CDR(proc);
     if NULLP(x) {x = UNSPECIFIED; goto retx;}
@@ -1548,38 +2124,49 @@ static SCM ceval_1(x)
   case (127 & IM_LET):
     ENV_MAY_PUSH(envpp);
     TRACE(x);
+#ifdef MAC_INLINE
+    t.arg1 = CAR(x);
+#endif
     x = CDR(x);
     ecache_evalx(CAR(CDR(x)));
-    EXTEND_ENV(CAR(x));
+#ifdef MAC_INLINE
+    if (t.arg1 != IM_LET)	/* inline call */
+      env_tail(ISYMVAL(t.arg1));
+#endif
+    STATIC_ENV = CAR(x);
+    EXTEND_VALENV;
     x = CDR(x);
     goto cdrxbegin;
   case (127 & IM_LETREC):
     ENV_MAY_PUSH(envpp);
     TRACE(x);
     x = CDR(x);
+    STATIC_ENV = CAR(x);
     scm_env_tmp = undefineds;
-    EXTEND_ENV(CAR(x));
+    EXTEND_VALENV;
     x = CDR(x);
     ecache_evalx(CAR(x));
-    EGC_ROOT(CAR(scm_env));
-    CDR(CAR(scm_env)) = scm_env_tmp;
+    EGC_ROOT(scm_env);
+    CAR(scm_env) = scm_env_tmp;
     scm_env_tmp = EOL;
     goto cdrxbegin;
   case (127 & IM_LETSTAR):
     ENV_MAY_PUSH(envpp);
     TRACE(x);
     x = CDR(x);
-    proc = CAR(x);
-    if IMP(proc) {
-      scm_env_tmp = EOL;
-      EXTEND_ENV(EOL);
-      goto cdrxbegin;
-    }
+    proc = CDR(CAR(x));
+    /* No longer happens.
+      if IMP(proc) {
+        scm_env_tmp = EOL;
+	EXTEND_VALENV;
+	goto cdrxbegin;
+	}
+    */
     do {
-      t.arg1 = CAR(proc);
-      proc = CDR(proc);
       scm_env_tmp = EVALCAR(proc);
-      EXTEND_ENV(t.arg1);
+      proc = CDR(proc);
+      STATIC_ENV = CAR(proc);
+      EXTEND_VALENV;
     } while NIMP(proc = CDR(proc));
     goto cdrxbegin;
   case (127 & IM_OR):
@@ -1609,7 +2196,7 @@ static SCM ceval_1(x)
 	  x = scm_multi_set(proc, arg2);
 	  goto retx;
 	}
-      else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
+      else *lookupcar(x) = arg2;
       break;
     case 1:
       I_VAL(proc) = arg2;
@@ -1624,9 +2211,10 @@ static SCM ceval_1(x)
     x = UNSPECIFIED;
 #endif
     goto retx;
-  case (127 & IM_DEFINE):	/* only for internal defines */
-    goto badfun;
-	/* new syntactic forms go here. */
+  case (127 & IM_FUNCALL):
+    x = CDR(x);
+    proc = ceval_1(CAR(x));
+    break;
   case (127 & MAKISYM(0)):
     proc = CAR(x);
     ASRTGO(ISYMP(proc), badfun);
@@ -1662,6 +2250,25 @@ static SCM ceval_1(x)
     case (ISYMNUM(IM_FARLOC_CDR)):
       x = *farlookup(x);
       goto retx;
+    case (ISYMNUM(IM_EVAL_FOR_APPLY)):
+      /* only happens when called from C-level apply or cvapply */
+      envpp = 1;
+      proc = CAR(scm_env_tmp);
+      scm_env_tmp = CDR(scm_env_tmp);
+      goto clo_unchecked;
+    case (ISYMNUM(IM_LET_SYNTAX)):
+      x = CDR(x);
+      STATIC_ENV = CAR(x);
+      goto cdrxbegin;
+    case (ISYMNUM(IM_ACRO_CALL)):
+      x = acro_call(x, STATIC_ENV);
+      goto loop;
+    case (ISYMNUM(IM_LINUM)):
+      goto expand;
+    case (ISYMNUM(IM_DEFINE)):
+      x = toplevel_define(x, STATIC_ENV);
+      goto retx;
+    /* new syntactic forms go here. */
     default:
       goto badfun;
     }
@@ -1669,9 +2276,11 @@ static SCM ceval_1(x)
     proc = x;
   badfun:
 #ifdef CAUTIOUS
-    scm_trace = UNDEFINED;
+    scm_trace = BOOL_F;
+    everr(xorig, STATIC_ENV, proc, s_wtap, "", 0);
+#else
+    everr(x, STATIC_ENV, proc, s_wtap, "", 0);
 #endif
-    everr(x, wrapenv(), proc, s_wtap, "");
   case tc7_vector:
   case tcs_uves:
   case tc7_smob:
@@ -1683,29 +2292,30 @@ static SCM ceval_1(x)
     proc = I_VAL(CAR(x));
     break;
   case tcs_cons_nimcar:
-    if ATOMP(CAR(x)) {
-      TOP_TRACE(x);
+  expand:
+    TOP_TRACE(x, STATIC_ENV);
 #ifdef MEMOIZE_LOCALS
-      x = macroexp1(x, UNDEFINED);
-      goto loop;
+    x = macroexp1(x, STATIC_ENV, EOL, 3);
+    goto loop;
 #else
-      proc = *lookupcar(x, 0);
-      if (NIMP(proc) && MACROP(proc)) {
-	x = macroexp1(x, UNDEFINED);
+    if ATOMP(CAR(x)) {
+      proc = scm_lookupval(x, 0);
+      if (KEYWORDP(proc)) {
+	x = macroexp1(x, STATIC_ENV, EOL, 3);
 	goto loop;
       }
-#endif
     }
     else proc = ceval_1(CAR(x));
+#endif
+  }
     /* At this point proc is the evaluated procedure from the function
        position and x has the form which is being evaluated. */
-  }
   ASRTGO(NIMP(proc), badfun);
   scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */
   if NULLP(CDR(x)) {
   evap0:
+    TOP_TRACE(xorig, STATIC_ENV);
     ENV_MAY_POP(envpp, CLOSUREP(proc));
-    TOP_TRACE(xorig);
     ALLOW_INTS_EGC;
     switch TYP7(proc) { /* no arguments given */
     case tc7_subr_0:
@@ -1728,8 +2338,8 @@ static SCM ceval_1(x)
 #ifdef CAUTIOUS
       if (0!=ARGC(proc)) {
       clo_checked:
+	t.arg1 = SCM_ENV_FORMALS(CAR(CODE(proc)));
 	DEFER_INTS_EGC;
-	t.arg1 = CAR(CODE(proc));
 	arg2 = scm_env_tmp;
 	while NIMP(t.arg1) {
 	  if NCONSP(t.arg1) goto clo_unchecked;
@@ -1745,17 +2355,22 @@ static SCM ceval_1(x)
     clo_unchecked:
       x = CODE(proc);
       scm_env = ENV(proc);
-      EXTEND_ENV(CAR(x));
+      STATIC_ENV = CAR(x);
+      EXTEND_VALENV;
       TRACE(CDR(x));
       goto cdrxbegin;
     case tc7_specfun:
+      switch TYP16(proc) {
+	/* default: break; */
 #ifdef CCLO
-      if (tc16_cclo==TYP16(proc)) {
+      case tc16_cclo:
 	t.arg1 = proc;
 	proc = CCLO_SUBR(proc);
 	goto evap1;
-      }
 #endif
+      case tc16_values:
+	return scm_values(UNDEFINED, UNDEFINED, EOL, s_values);
+      }
     case tc7_contin:
     case tc7_subr_1:
     case tc7_subr_2:
@@ -1764,28 +2379,33 @@ static SCM ceval_1(x)
     case tc7_subr_3:
     case tc7_lsubr_2:
     umwrongnumargs:
-      unmemocar(x);
     wrongnumargs:
       if (envpp < 0) {
 	scm_estk_ptr += SCM_ESTK_FRLEN;
 	scm_env = scm_estk_ptr[0];
       }
-      TOP_TRACE(UNDEFINED);
-      everr(x, wrapenv(), proc, (char *)WNA, "");
+#ifdef CAUTIOUS
+      if (xorig==scm_trace) STATIC_ENV = scm_trace_env;
+      TOP_TRACE(BOOL_F, BOOL_F);
+      everr(xorig, STATIC_ENV, proc, (char *)WNA, "", 0);
+#else
+      everr(x, STATIC_ENV, proc, (char *)WNA, "", 0);
+#endif
     default:
       goto badfun;
     }
   }
   x = CDR(x);
 #ifdef CAUTIOUS
-  if (IMP(x)) goto wrongnumargs;
+  if (IMP(x))
+    goto wrongnumargs;
 #endif
   t.arg1 = EVALCAR(x);
   x = CDR(x);
   if NULLP(x) {
+    TOP_TRACE(xorig, STATIC_ENV);
 evap1:
     ENV_MAY_POP(envpp, CLOSUREP(proc));
-    TOP_TRACE(xorig);
     ALLOW_INTS_EGC;
     switch TYP7(proc) { /* have one argument in t.arg1 */
     case tc7_subr_2o:
@@ -1795,39 +2415,39 @@ evap1:
       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);
+      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);
+	if BIGP(t.arg1)
+	  return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
 # endif
-    floerr:
-      wta(t.arg1, (char *)ARG1, SNAME(proc));
-    }
+      floerr:
+	wta(t.arg1, (char *)ARG1, SNAME(proc));
+      }
 #endif
-    {
-      int op = CXR_OP(proc);
+      {
+	int op = CXR_OP(proc);
 #ifndef RECKLESS
-      x = t.arg1;
+	x = t.arg1;
 #endif
-      while (op) {
-	ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
-	       x, ARG1, SNAME(proc));
-	t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1));
-	op >>= 2;
+	while (op) {
+	  ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
+		 x, ARG1, SNAME(proc));
+	  t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1));
+	  op >>= 2;
+	}
+	return 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));
+    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));
     case tcs_closures:
       ENV_MAY_PUSH(envpp);
 #ifdef SCM_PROFILE
@@ -1850,7 +2470,8 @@ evap1:
 	DEFER_INTS_EGC;
 	t.arg1 = scm_make_cont();
 	EGC_ROOT(t.arg1);
-	if ((x = setjump(CONT(t.arg1)->jmpbuf))) {
+	x = setjump(CONT(t.arg1)->jmpbuf);
+	if (x) {
 #ifdef SHORT_INT
 	  x = (SCM)thrown_value;
 #endif
@@ -1863,17 +2484,22 @@ evap1:
 	goto evap1;
       case tc16_eval:
 	ENV_MAY_PUSH(envpp);
-	TRACE(x);
+	TRACE(t.arg1);
+	STATIC_ENV = eval_env;
 	scm_env = EOL;
-	x = cons(copytree(t.arg1), EOL);
-	goto begin;
+	x = t.arg1;
+	if (IMP(x)) goto retx;
+	goto loop;
 #ifdef CCLO
       case tc16_cclo:
-	arg2 = t.arg1;
-	t.arg1 = proc;
-	proc = CCLO_SUBR(proc);
-	goto evap2;
-#endif
+	arg2 = UNDEFINED;
+	goto cclon;
+	/* arg2 = t.arg1;
+	   t.arg1 = proc;
+	   proc = CCLO_SUBR(proc);
+	   goto evap2; */
+#endif
+      case tc16_values: return t.arg1;
       }
     case tc7_subr_2:
     case tc7_subr_0:
@@ -1891,9 +2517,9 @@ evap1:
     arg2 = EVALCAR(x);
     x = CDR(x);
     if NULLP(x) {		/* have two arguments */
+      TOP_TRACE(xorig, STATIC_ENV);
   evap2:
       ENV_MAY_POP(envpp, CLOSUREP(proc));
-      TOP_TRACE(xorig);
       ALLOW_INTS_EGC;
       switch TYP7(proc) {
       case tc7_subr_2:
@@ -1910,6 +2536,7 @@ evap1:
 	switch TYP16(proc) {
 	case tc16_apply:
 	  proc = t.arg1;
+	  ASRTGO(NIMP(proc), badfun);
 	  if NULLP(arg2) goto evap0;
 	  if (IMP(arg2) || NCONSP(arg2)) {
 	    x = arg2;
@@ -1926,7 +2553,7 @@ evap1:
 	  if NULLP(x) goto evap2;
 	  ASRTGO(NIMP(x) && CONSP(x), badlst);
 	  arg3 = x;
-	  x = copy_list(CDR(x), 0);
+	  x = scm_cp_list(CDR(x), 0);
 #ifndef RECKLESS
 	  if UNBNDP(x) {x = arg3; goto badlst;}
 #endif
@@ -1934,14 +2561,32 @@ evap1:
 	  goto evap3;
 #ifdef CCLO
 	case tc16_cclo: cclon:
-	  return apply(CCLO_SUBR(proc),
-		       cons2(proc, t.arg1, cons(arg2, x)), EOL);
-       /* arg3 = arg2;
+	  arg3 = arg2;
 	  arg2 = t.arg1;
 	  t.arg1 = proc;
 	  proc = CCLO_SUBR(proc);
-	  goto evap3; */
+	  if (UNBNDP(arg3)) goto evap2;
+	  goto evap3;
+	  /* return apply(CCLO_SUBR(proc),
+		       cons2(proc, t.arg1, cons(arg2, x)), EOL); */
 #endif
+	case tc16_values:
+	  return scm_values(t.arg1, arg2, EOL, s_values);
+	case tc16_call_wv:
+	  ENV_MAY_PUSH(envpp);
+	  scm_env_tmp = IM_VALUES_TOKEN; /* Magic value recognized by VALUES */
+	  t.arg1 = apply(t.arg1, EOL, EOL);
+	  proc = arg2;
+	  DEFER_INTS_EGC;
+	  if (IM_VALUES_TOKEN==scm_env_tmp) {
+	    scm_env_tmp = EOL;
+	    if (UNBNDP(t.arg1)) goto evap0;
+	    goto evap1;
+	  }
+	  arg2 = CAR(scm_env_tmp);
+	  x = CDR(scm_env_tmp);
+	  goto apply4;   /* Jumping to apply code results in extra list copy
+			    for >=3 args, but we want to minimize bloat. */
 	}
       case tc7_subr_0:
       case tc7_cxr:
@@ -1976,6 +2621,7 @@ evap1:
       x = CDR(x);
       if NIMP(x) {
 	if (CLOSUREP(proc) && 3==ARGC(proc)) {
+	  ALLOW_INTS_EGC;
 	  ENV_MAY_PUSH(envpp);
 	  if (ecache_eval_args(proc, t.arg1, arg2, arg3, x))
 	    goto clo_unchecked;
@@ -1983,9 +2629,9 @@ evap1:
 	}
 	x = eval_args(x);
       }
+      TOP_TRACE(xorig, STATIC_ENV);
     evap3:
       ENV_MAY_POP(envpp, CLOSUREP(proc));
-      TOP_TRACE(xorig);
       ALLOW_INTS_EGC;
       switch TYP7(proc) {
       case tc7_subr_3:
@@ -2006,8 +2652,7 @@ evap1:
 #endif
 	switch ARGC(proc) {
 	case 3:
-	  scm_env_cons2(arg2, arg3, x);
-	  scm_env_cons_tmp(t.arg1);
+	  scm_env_cons3(t.arg1, arg2, arg3, x);
 	  goto clo_checked;
 	case 2:
 	  scm_env_cons2(t.arg1, arg2, cons(arg3, x));
@@ -2023,6 +2668,7 @@ evap1:
 	switch TYP16(proc) {
 	case tc16_apply:
 	  proc = t.arg1;
+	  ASRTGO(NIMP(proc), badfun);
 	  t.arg1 = arg2;
 	  if IMP(x) {
 	    x = arg3;
@@ -2041,6 +2687,8 @@ evap1:
 	  x = cons(arg3, x);
 	  goto cclon;
 #endif
+	case tc16_values:
+	  return scm_values(t.arg1, arg2, cons(arg3, x), s_values);
 	}
       case tc7_subr_2:
       case tc7_subr_1o:
@@ -2074,16 +2722,14 @@ static char s_proc_doc[] = "procedure-documentation";
 SCM l_proc_doc(proc)
      SCM proc;
 {
-  SCM code;
+  SCM env;
   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;
+    env = CAR(CODE(proc));
+    env = scm_env_getprop(SCM_ENV_DOC, CAR(CODE(proc)));
+    return IMP(env) ? BOOL_F : CAR(env);
   default:
     return BOOL_F;
 /*
@@ -2117,7 +2763,7 @@ SCM nconc2copy(lst)
 }
 /* Shallow copy.  If LST is not a proper list of length at least
    MINLEN, returns UNDEFINED */
-SCM copy_list(lst, minlen)
+SCM scm_cp_list(lst, minlen)
      SCM lst;
      int minlen;
 {
@@ -2132,15 +2778,14 @@ SCM copy_list(lst, minlen)
     return res;
   return UNDEFINED;
 }
-SCM scm_v2lst(n, v)
+SCM scm_v2lst(n, v, end)
      long n;
-     SCM *v;
+     SCM *v, end;
 {
-  SCM res = EOL;
+  SCM res = end;
   for(n--; n >= 0; n--) res = cons(v[n], res);
   return res;
 }
-static SCM f_apply_closure;
 SCM apply(proc, arg1, args)
      SCM proc, arg1, args;
 {
@@ -2192,7 +2837,7 @@ SCM apply(proc, arg1, args)
 	return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
 # endif
     floerr:
-      wta(arg1, (char *)ARG1, CHARS(SNAME(proc)));
+      wta(arg1, (char *)ARG1, SNAME(proc));
     }
 #endif
     {
@@ -2234,29 +2879,16 @@ SCM apply(proc, arg1, args)
       args = CDR(args);
     }
     return BOOL_T;
-  case tcs_closures:
+  case tcs_closures: {
     arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
 #ifndef RECKLESS
-    if (badargsp(proc, arg1)) goto wrongnumargs;
+    if (badargsp(SCM_ENV_FORMALS(CAR(CODE(proc))), arg1)) goto wrongnumargs;
 #endif
     ENV_PUSH;
-    PUSH_TRACE;
-    scm_env_tmp = arg1;
-    scm_env = ENV(proc);
-    proc = CODE(proc);
-    EXTEND_ENV(CAR(proc));
-    proc = CDR(proc);
-    while NNULLP(proc) {
-      if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
-        proc = m_expand_body(proc);
-        continue;
-      }
-      arg1 = EVALCAR(proc);
-      proc = CDR(proc);
-    }
-    ENV_POP;
-    ALLOW_INTS_EGC;
+    scm_env_cons(proc, arg1);
+    arg1 = ceval_1(f_evapply);
     return arg1;
+  }
   case tc7_contin:
     ASRTGO(NULLP(args), wrongnumargs);
     scm_dynthrow(proc, arg1);
@@ -2272,8 +2904,8 @@ SCM apply(proc, arg1, args)
   }
 }
 
-/* This function does not check that proc is a procedure, nor the
-   number of arguments, call scm_arity_check to do that. */
+/* This function does not check that proc is a procedure, nor that
+   it accepts n arguments.  Call scm_arity_check to do that. */
 SCM scm_cvapply(proc, n, argv)
      SCM proc, *argv;
      long n;
@@ -2290,7 +2922,6 @@ SCM scm_cvapply(proc, n, argv)
   case tc7_subr_2:
     return SUBRF(proc)(argv[0], argv[1]);
   case tc7_subr_0:
-  subr0:
     return SUBRF(proc)();
   case tc7_subr_1o:
     if (0==n) return SUBRF(proc)(UNDEFINED);
@@ -2310,7 +2941,7 @@ SCM scm_cvapply(proc, n, argv)
 	return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0);
 # endif
     floerr:
-      wta(argv[0], (char *)ARG1, CHARS(SNAME(proc)));
+      wta(argv[0], (char *)ARG1, SNAME(proc));
     }
 #endif
     {
@@ -2327,12 +2958,12 @@ SCM scm_cvapply(proc, n, argv)
   case tc7_subr_3:
     return SUBRF(proc)(argv[0], argv[1], argv[2]);
   case tc7_lsubr:
-    return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv));
+    return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv, EOL));
   case tc7_lsubr_2:
     return SUBRF(proc)(argv[0], argv[1],
-		       2==n ? EOL : scm_v2lst(n-2, &argv[2]));
+		       2==n ? EOL : scm_v2lst(n-2, &argv[2], EOL));
   case tc7_asubr:
-    if (1 >= n) return SUBRF(proc)(0==n ? argv[0] : UNDEFINED, UNDEFINED);
+    if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED: argv[0], UNDEFINED);
     res = argv[0];
     for (i = 1; i < n; i++)
       res = SUBRF(proc)(res, argv[i]);
@@ -2342,34 +2973,23 @@ SCM scm_cvapply(proc, n, argv)
     for (i = 0; i < n-1; i++)
       if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F;
     return BOOL_T;
-  case tcs_closures:
+  case tcs_closures: {
+    SCM p = proc;
     ENV_PUSH;
-    PUSH_TRACE;
     i = ARGC(proc);
     if (3==i) {
       scm_env_tmp = EOL;
-      scm_env_v2lst((int)n, argv);
+      ENV_V2LST(n, argv);
     }
     else {
-      scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL;
+      scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i], EOL) : EOL;
       if (i>0)
-	scm_env_v2lst((int)i, argv);
-    }
-    scm_env = ENV(proc);
-    proc = CODE(proc);
-    EXTEND_ENV(CAR(proc));
-    proc = CDR(proc);
-    while NNULLP(proc) {
-      if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
-        proc = m_expand_body(proc);
-        continue;
-      }
-      res = EVALCAR(proc);
-      proc = CDR(proc);
+	ENV_V2LST(i, argv);
     }
-    ENV_POP;
-    ALLOW_INTS_EGC;
+    ENV_V2LST(1L, &p);
+    res = ceval_1(f_evapply);
     return res;
+  }
   case tc7_contin:
     scm_dynthrow(proc, argv[0]);
   case tc7_specfun:
@@ -2382,7 +3002,7 @@ SCM scm_cvapply(proc, n, argv)
 #endif
       goto tail;
     }
-    res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv));
+    res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv, EOL));
 #ifdef CCLO
     proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
 #else
@@ -2401,10 +3021,6 @@ SCM map(proc, arg1, args)
   long i, n = ilength(args) + 1;
   scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
   if NULLP(arg1) return res;
-#ifdef CAUTIOUS
-  ENV_PUSH;
-  PUSH_TRACE;
-#endif
 #ifndef RECKLESS
   scm_arity_check(proc, n, s_map);
 #endif
@@ -2424,21 +3040,20 @@ SCM map(proc, arg1, args)
     ave = &(ve[n]);
   }
   ve[0] = arg1;
-  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map);
+  ASSERT(NIMP(ve[0]), arg1, ARG2, s_map);
   for (i = 1; i < n; i++) {
     ve[i] = CAR(args);
-    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map);
+    ASSERT(NIMP(ve[i]), ve[i], ARGn, s_map);
     args = CDR(args);
   }
   while (1) {
     arg1 = EOL;
     for (i = n-1;i >= 0;i--) {
       if IMP(ve[i]) {
-#ifdef CAUTIOUS
-	ENV_POP;
-#endif
+	/* We could check for lists the same length here. */
 	return res;
       }
+      ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_map);
       ave[i] = CAR(ve[i]);
       ve[i] = CDR(ve[i]);
     }
@@ -2454,10 +3069,6 @@ SCM for_each(proc, arg1, args)
   long i, n = ilength(args) + 1;
   scm_protect_temp(&heap_ve);  /* Keep heap_ve from being optimized away. */
   if NULLP(arg1) return UNSPECIFIED;
-#ifdef CAUTIOUS
-  ENV_PUSH;
-  PUSH_TRACE;
-#endif
 #ifndef RECKLESS
   scm_arity_check(proc, n, s_map);
 #endif
@@ -2477,21 +3088,19 @@ SCM for_each(proc, arg1, args)
     ave = &(ve[n]);
   }
   ve[0] = arg1;
-  ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each);
+  ASSERT(NIMP(ve[0]), arg1, ARG2, s_for_each);
   for (i = 1; i < n; i++) {
     ve[i] = CAR(args);
-    ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each);
+    ASSERT(NIMP(ve[i]), args, ARGn, s_for_each);
     args = CDR(args);
   }
   while (1) {
     arg1 = EOL;
     for (i = n-1;i >= 0;i--) {
       if IMP(ve[i]) {
-#ifdef CAUTIOUS
-	ENV_POP;
-#endif
 	return UNSPECIFIED;
       }
+      ASSERT(CONSP(ve[i]), ve[i], 0==i ? ARG2 : ARGn, s_for_each);
       ave[i] = CAR(ve[i]);
       ve[i] = CDR(ve[i]);
     }
@@ -2535,129 +3144,85 @@ static int prinprom(exp, port, writing)
      SCM port;
      int writing;
 {
-  lputs("#<promise ", port);
+  lputs("#<promise", port);
+  if ((2L<<16) & CAR(exp)) lputc('*', port);
+  lputc(' ', port);
   iprin1(CDR(exp), port, writing);
   lputc('>', port);
   return !0;
 }
 
+static SCM makro(code, flags, what)
+     SCM code;
+     long flags;
+     char *what;
+{
+  register SCM z;
+  ASSERT(scm_arity_check(code, (MAC_PRIMITIVE & flags ? 3L : 2L),
+			 (char *)0), code, ARG1, what);
+  NEWCELL(z);
+  CDR(z) = code;
+  CAR(z) = tc16_macro | (flags << 16);
+  return z;
+}
 static char s_makacro[] = "procedure->syntax";
 SCM makacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro;
-	return z;
+  return makro(code, MAC_ACRO, s_makacro);
 }
 static char s_makmacro[] = "procedure->macro";
 SCM makmacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro | (1L<<16);
-	return z;
+  return makro(code, MAC_MACRO, s_makmacro);
 }
 static char s_makmmacro[] = "procedure->memoizing-macro";
 SCM makmmacro(code)
      SCM code;
 {
-	register SCM z;
-	ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro);
-	NEWCELL(z);
-	CDR(z) = code;
-	CAR(z) = tc16_macro | (2L<<16);
-	return z;
+  return makro(code, MAC_MMACRO, s_makmmacro);
+}
+static char s_makidmacro[] = "procedure->identifier-macro";
+SCM makidmacro(code)
+     SCM code;
+{
+  return makro(code, MAC_IDMACRO, s_makidmacro);
 }
 #ifdef MACRO
-/* Functions for (eventual) smart expansion */
+/* Functions for  smart expansion */
+
+/* @MACROEXPAND1 returns:
+   #F if its argument is not a macro invocation,
+   the argument if the argument is a primitive syntax invocation,
+   the result of expansion if the argument is a macro invocation
+   (BEGIN #F) will be returned instead of #F if #F is the result.
+ */
 static char s_macroexpand1[] = "@macroexpand1";
 SCM scm_macroexpand1(x, env)
      SCM x, env;
 {
-  SCM res, proc;
-  if (IMP(x) || NCONSP(x)) return x;
-  res = CAR(x);
-  if (IMP(res) || !IDENTP(res)) return x;
-  ENV_PUSH;
-  PUSH_TRACE;
-  if (NULLP(env))
-    scm_env = env;
-  else {
-    ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1);
-    scm_env = CDR(env);
+  SCM name;
+  if (IMP(x)) return BOOL_F;
+  if (CONSP(x)) {
+    name = CAR(x);
+    if (IMP(name) || !IDENTP(name)) return BOOL_F; /* probably an error */
   }
-  proc = *lookupcar(x, 0);
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  if (NIMP(proc) && MACROP(proc)) {
-    SCM argv[2];
-    switch ((int)(CAR(proc)>>16) & 0x7f) {
-    default: return x;		/* Primitive macro invocation. */
-    case 2: case 1:
-      argv[0] = x;
-      argv[1] = env;
-      res = scm_cvapply(CDR(proc), 2L, argv);
-      if (res==x) return cons(CAR(x), CDR(x));
-      return res;
-    case 0: case 4:		/* Acros, primitive or not. */
-      argv[0] = x;
-      argv[1] = env;
-      return cons2(TOPRENAME(i_quote),
-		   scm_cvapply(CDR(proc), 2L, argv),
-		   EOL);
-    }
+  else if (IDENTP(x)) {
+    name = x;
   }
-  return x;
-}
-static char s_env_ref[] = "environment-ref";
-SCM scm_env_ref(env, ident)
-     SCM env, ident;
-{
-  SCM *p, ret;
-  if NULLP(env) return BOOL_F;
-  ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref);
-  ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref);
-  ENV_PUSH;
-  PUSH_TRACE;
-  scm_env = CDR(env);
-  p = id_denote(ident);
-  ret = p ? *p : BOOL_F;
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  return ret;
-}
-static char s_extended_env[] = "extended-environment";
-SCM scm_extended_env(names, vals, env)
-     SCM names, vals, env;
-{
-  SCM z, nenv;
-# ifndef RECKLESS
-  SCM v = vals;
-  z = names;
-  for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) {
-    ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env);
-    v = CDR(v);
-  }
-  ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env);
-# endif
-  nenv = acons(names, vals, env2tree(env));
-  NEWCELL(z);
-  CDR(z) = nenv;
-  CAR(z) = tc16_env | (1L << 16);
-  return z;
+  else
+    return BOOL_F;
+  return macroexp1(x, env, BOOL_F, 0);
 }
+
 static char s_eval_syntax[] = "eval-syntax";
 SCM scm_eval_syntax(x, env)
      SCM x, env;
 {
-  ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax);
-  return EVAL(x, env);
+  SCM venv = cons(undefineds, undefineds);
+  CDR(venv) = venv;
+  return EVAL(x, env, venv);
 }
 #endif /* MACRO */
 
@@ -2666,11 +3231,19 @@ static int prinmacro(exp, port, writing)
      SCM port;
      int writing;
 {
-  if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port);
-  else lputs("#<", port);
-  if (CAR(exp) & (3L<<16)) lputs("macro", port);
-  else lputs("syntax", port);
-  if (CAR(exp) & (2L<<16)) lputc('!', port);
+  lputs("#<", port);
+  if (MAC_TYPE(exp) & MAC_PRIMITIVE) lputs("primitive-", port);
+  switch (MAC_TYPE(exp) & ~MAC_PRIMITIVE) {
+  default:
+    lputs("macro", port); break;
+  case MAC_ACRO:
+    lputs("syntax", port); break;
+#ifdef MAC_INLINE
+  case MAC_INLINE:
+    lputs("inline function", port); break;
+#endif
+  }
+  if (MAC_TYPE(exp) & MAC_MEMOIZING) lputc('!', port);
   lputc(' ', port);
   iprin1(CDR(exp), port, writing);
   lputc('>', port);
@@ -2694,8 +3267,8 @@ static int prinid(exp, port, writing)
      int writing;
 {
   SCM s = IDENT_PARENT(exp);
-  while (!IDENTP(s)) s = IDENT_PARENT(s);
-  lputs("#<identifier ", port);
+  while (M_IDENTP(s)) s = IDENT_PARENT(s);
+  lputs("#<id ", port);
   iprin1(s, port, writing);
   lputc(':', port);
   intprint((long)exp, -16, port);
@@ -2707,17 +3280,41 @@ char s_force[] = "force";
 SCM force(x)
      SCM x;
 {
-  ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force);
-  if (!((1L<<16) & CAR(x))) {
-    SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0);
-    if (!((1L<<16) & CAR(x))) {
-      DEFER_INTS;
-      CDR(x) = ans;
-      CAR(x) |= (1L<<16);
-      ALLOW_INTS;
+ tail:
+  ASRTGO(NIMP(x) && (TYP16(x)==tc16_promise), badx);
+  switch (CAR(x)>>16) {
+  default:
+  badx: wta(x, (char *)ARG1, s_force);
+  case 0:
+    {
+      SCM ans;
+      int mv = (IM_VALUES_TOKEN==scm_env_tmp);
+      ans = scm_cvapply(CDR(x), 0L, (SCM *)0);
+      if (mv) {
+	DEFER_INTS_EGC;
+	if (IM_VALUES_TOKEN==scm_env_tmp) {
+	  if (!UNBNDP(ans)) mv = 0;
+	}
+	else {
+	  ans = cons2(ans, CAR(scm_env_tmp), CDR(scm_env_tmp));
+	  scm_env_tmp = IM_VALUES_TOKEN;
+	}
+	ALLOW_INTS_EGC;
+      }
+      if (!((1L<<16) & CAR(x))) {
+	DEFER_INTS;
+	CDR(x) = ans;
+	CAR(x) |= mv ? (3L<<16) : (1L<<16);
+	ALLOW_INTS;
+      }
+      goto tail;
     }
+  case 1: return CDR(x);
+  case 3:
+    x = CDR(x);
+    if (UNBNDP(x)) return scm_values(UNDEFINED, UNDEFINED, EOL, s_force);
+    return scm_values(CAR(x), CAR(CDR(x)), CDR(CDR(x)), s_force);
   }
-  return CDR(x);
 }
 
 SCM copytree(obj)
@@ -2743,7 +3340,7 @@ SCM eval(obj)
      SCM obj;
 {
   obj = copytree(obj);
-  return EVAL(obj, (SCM)EOL);
+  return EVAL(obj, EOL, EOL);
 }
 
 SCM definedp(x, env)
@@ -2771,7 +3368,7 @@ static char s_ident_eqp[] = "identifier-equal?";
 SCM ident_eqp(id1, id2, env)
      SCM id1, id2, env;
 {
-  SCM s1 = id1, s2 = id2, ret;
+  SCM s1 = id1, s2 = id2;
 # ifndef RECKLESS
   if IMP(id1)
   badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
@@ -2784,16 +3381,12 @@ SCM ident_eqp(id1, id2, env)
   ASRTGO(SYMBOLP(s1), badarg1);
   ASRTGO(SYMBOLP(s2), badarg2);
   if (s1 != s2) return BOOL_F;
-  ENV_PUSH;
-  PUSH_TRACE;
-  if NULLP(env) scm_env = env;
-  else {
-    ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp);
-    scm_env = CDR(env);
-  }
-  ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
-  ENV_POP;
-  return ret;
+  s1 = scm_env_lookup(id1, env);
+  s2 = scm_env_lookup(id2, env);
+  if (s1==s2) return BOOL_T;
+  if (NIMP(s1) && ISYMP(CAR(s1)))	/* FARLOC case */
+    return equal(s1, s2);
+  return BOOL_F;
 }
 
 static char s_ident2sym[] = "identifier->symbol";
@@ -2811,13 +3404,22 @@ SCM renamed_ident(id, env)
 {
   SCM z;
   ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
-  if NIMP(env) {
-    ASSERT(ENVP(env), env, ARG2, s_renamed_ident);
-    DEFER_INTS_EGC;
-    env = CDR(env);
-  }
   NEWCELL(z);
-  if IMP(env) {
+  while (NIMP(env)) {
+    if (INUMP(CAR(env))) {
+      ASSERT(NIMP(CDR(env)), env, s_badenv, s_renamed_ident);
+      env = CDR(CDR(env));
+    }
+    else if (SCM_LINUMP(CAR(env))) {
+      env = CDR(env);
+    }
+    else {
+      ASSERT(NULLP(env) || (NIMP(env) && CONSP(env)),
+	     env, s_badenv, s_renamed_ident);
+      break;
+    }
+  }
+  if (scm_nullenv_p(env)) {
     CAR(z) = tc16_ident;
     CDR(z) = id;
     return z;
@@ -2825,7 +3427,7 @@ SCM renamed_ident(id, env)
   else {
     SCM y;
     CAR(z) = id;
-    CDR(z) = CAR(CAR(env));
+    CDR(z) = env;
     NEWCELL(y);
     CAR(y) = tc16_ident | 1L<<16;
     CDR(y) = z;
@@ -2834,117 +3436,119 @@ SCM renamed_ident(id, env)
 }
 
 static char s_syn_quote[] = "syntax-quote";
-SCM m_syn_quote(xorig, env)
-     SCM xorig, env;
+SCM m_syn_quote(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
   ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_syn_quote);
   return cons(IM_QUOTE, CDR(xorig));
 }
 
-/* Ensure that the environment for LET-SYNTAX can be uniquely identified. */
-SCM m_atlet_syntax(xorig, env)
-     SCM xorig, env;
-{
-  SCM mark;
-  DEFER_INTS_EGC;
-  if (NIMP(env) && ENVP(env))
-    env = CDR(env);
-  if NULLP(env) return m_let(xorig, env);
-  mark = CAR(CAR(env));
-  if (NIMP(mark) && CONSP(mark)) return m_let(xorig, env);
-  mark = renamed_ident(i_mark, BOOL_F);
-  return m_letstar(cons2(i_let,
-			 cons(cons2(mark, BOOL_F, EOL), EOL),
-			 acons(TOPRENAME(i_let), CDR(xorig), EOL)),
-		   env);
+static char s_defsyntax[] = "defsyntax";
+SCM m_defsyntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM x = CDR(xorig), name, val;
+  ASSYNT(ilength(x)==2, xorig, s_expression, s_defsyntax);
+  ASSYNT(scm_nullenv_p(env), xorig, s_placement, s_defsyntax);
+  name = CAR(x);
+  ASSYNT(NIMP(name) && IDENTP(name), name, s_variable, s_defsyntax);
+  val = evalcar(CDR(x));
+  ASSYNT(NIMP(val) && MACROP(val), CAR(CDR(x)), s_expr, s_defsyntax);
+  checked_define(name, cons(IM_KEYWORD, val), s_defsyntax);
+  return UNSPECIFIED;
+}
+
+SCM m_let_syntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM proc, vars, inits, fr;
+  SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits);
+  /*  if (IMP(vars)) return m_let_null(body, env, ctxt); */
+  /* Add a unique frame for an environment mark. */
+  env = EXTEND_ENV(cons(SCM_ENV_SYNTAX, EOL), env);
+  for (fr = EOL; NIMP(inits); inits = CDR(inits)) {
+    proc = scm_eval_syntax(CAR(inits), env);
+    ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_let_syntax);
+    fr = acons(CAR(vars), proc, fr);
+    vars = CDR(vars);
+  }
+  fr = cons(SCM_ENV_SYNTAX, fr);
+  env = EXTEND_ENV(fr, env);
+  return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt));
+}
+static char s_letrec_syntax[] = "letrec-syntax";
+SCM m_letrec_syntax(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
+{
+  SCM proc, vars, vals, inits, fr;
+  SCM body = m_parse_let(EOL, xorig, CDR(xorig), &vars, &inits);
+  /*  if (IMP(vars)) return m_let_null(body, env, ctxt); */
+  for (fr = EOL; NIMP(vars); vars = CDR(vars))
+    fr = acons(CAR(vars), UNDEFINED, fr);
+  fr = cons(SCM_ENV_SYNTAX, fr);
+  env = EXTEND_ENV(fr, env);
+  for (vals = EOL; NIMP(inits); inits = CDR(inits)) {
+    proc = scm_eval_syntax(CAR(inits), env);
+    ASSYNT(NIMP(proc) && MACROP(proc), CAR(inits), s_expr, s_letrec_syntax);
+    vals = cons(proc, vals);
+  }
+  for (fr = CDR(fr); NIMP(fr); fr = CDR(fr)) {
+    CDR(CAR(fr)) = CAR(vals);
+    vals = CDR(vals);
+  }
+  return cons2(IM_LET_SYNTAX, env, m_body(body, env, ctxt));
 }
 
 static char s_the_macro[] = "the-macro";
-SCM m_the_macro(xorig, env)
-     SCM xorig, env;
+SCM m_the_macro(xorig, env, ctxt)
+     SCM xorig, env, ctxt;
 {
-  SCM x = CDR(xorig);
+  SCM addr, x = CDR(xorig);
   ASSYNT(1==ilength(x), xorig, s_expression, s_the_macro);
-  if (NIMP(CAR(x)) && IDENTP(CAR(x)))
-    x = *lookupcar(x, LOOKUP_UNDEFP);
-  else
-    x = evalcar(x);
-  ASSYNT(NIMP(x) && MACROP(x), xorig, ARG1, s_the_macro);
-  return cons2(IM_QUOTE, x, EOL);
+  x = CAR(x);
+  ASSYNT(NIMP(x) && IDENTP(x), x, s_expression, s_the_macro);
+  addr = scm_env_lookup(x, env);
+				/* Require global ref for now. */
+  ASSYNT(NIMP(addr) && SYMBOLP(addr), x, s_expression, s_the_macro);
+  x = CDR(sym2vcell(addr));
+  ASSYNT(KEYWORDP(x), xorig, ARG1, s_the_macro);
+  return KEYWORD_MACRO(x);
 }
 #endif
 
-static char s_env2tree[] = "environment->tree";
-SCM env2tree(env)
-     SCM env;
-{
-  SCM ans, a, *lloc;
-  if NULLP(env) return env;
-  ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env2tree);
-  if ((1L << 16) & CAR(env)) return CDR(env);
-  if IMP(CDR(env)) return CDR(env);
-  ENV_PUSH;
-  PUSH_TRACE;
-  scm_env = CDR(env);
-  ans = a = cons(UNSPECIFIED, UNSPECIFIED);
-  while (!0) {
-    scm_env_tmp = CAR(scm_env);
-    lloc = &CAR(a);
-    while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
-      if (undefineds==*lloc) {
-        *lloc = BOOL_F;
-        break;
-      }
-      *lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
-      lloc = &CDR(*lloc);
-      DEFER_INTS_EGC;
-      scm_env_tmp = CDR(scm_env_tmp);
-    }
-    scm_env = CDR(scm_env);
-    if IMP(scm_env) {
-      CDR(a) = scm_env;
-      break;
-    }
-    a = (CDR(a) = cons(UNSPECIFIED, UNSPECIFIED));
-  }
-  ENV_POP;
-  ALLOW_INTS_EGC;
-  CDR(env) = ans;		/* Memoize migrated environment. */
-  CAR(env) |= (1L << 16);
-  return ans;
-}
-
 static iproc subr1s[] = {
 	{"@copy-tree", copytree},
 /*	{s_eval, eval}, now a (tail recursive) specfun */
 	{s_force, force},
 	{s_proc_doc, l_proc_doc},
-	{"procedure->syntax", makacro},
-	{"procedure->macro", makmacro},
-	{"procedure->memoizing-macro", makmmacro},
+	{s_makacro, makacro},
+	{s_makmacro, makmacro},
+	{s_makmmacro, makmmacro},
+	{s_makidmacro, makidmacro},
 	{"apply:nconc-to-last", nconc2copy},
-	{s_env2tree, env2tree},
+	/*	{s_env2tree, env2tree}, */
 #ifdef MACRO
 	{s_identp, identp},
 	{s_ident2sym, ident2sym},
 #endif
 	{0, 0}};
 
-static iproc lsubr2s[] = {
-/*	{s_apply, apply}, now explicity initted */
-	{s_map, map},
-	{s_for_each, for_each},
+static iproc subr2s[] = {
 #ifdef MACRO
 	{s_macroexpand1, scm_macroexpand1},
-	{s_env_ref, scm_env_ref},
 	{s_eval_syntax, scm_eval_syntax},
 #endif
 	{0, 0}};
 
+static iproc lsubr2s[] = {
+/*	{s_apply, apply}, now explicity initted */
+	{s_map, map},
+	{s_for_each, for_each},
+	{0, 0}};
+
 static iproc subr3s[] = {
 #ifdef MACRO
   {s_ident_eqp, ident_eqp},
-  {s_extended_env, scm_extended_env},
 #endif
   {0, 0}};
 
@@ -2955,25 +3559,28 @@ static smobfuns envsmob = {markcdr, free0, prinenv};
 static smobfuns idsmob = {markcdr, free0, prinid};
 #endif
 
-SCM make_synt(name, macroizer, fcn)
+SCM make_synt(name, flags, fcn)
      const char *name;
-     SCM (*macroizer)();
+     long flags;
      SCM (*fcn)();
 {
   SCM symcell = sysintern(name, UNDEFINED);
-  SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn));
-  CAR(z) |= (4L << 16);         /* Flags result as primitive macro. */
+  SCM z = makro(scm_maksubr(name, tc7_subr_3, fcn),
+		flags | MAC_PRIMITIVE, "make_synt");
+#ifdef MACRO
+  z = cons(IM_KEYWORD, z);
+#endif
   CDR(symcell) = z;
   return CAR(symcell);
 }
-SCM make_specfun(name, typ)
+SCM make_specfun(name, typ, flags)
      char *name;
-     int typ;
+     int typ, flags;
 {
   SCM symcell = sysintern(name, UNDEFINED);
   register SCM z;
   NEWCELL(z);
-  CAR(z) = (long)typ;
+  CAR(z) = (long)typ | ((long)flags)<<16;
   CDR(z) = CAR(symcell);
   CDR(symcell) = z;
   return z;
@@ -2984,56 +3591,81 @@ void init_eval()
   tc16_macro = newsmob(&macrosmob);
   tc16_env = newsmob(&envsmob);
   init_iprocs(subr1s, tc7_subr_1);
+  init_iprocs(subr2s, tc7_subr_2);
   init_iprocs(lsubr2s, tc7_lsubr_2);
   init_iprocs(subr3s, tc7_subr_3);
 #ifdef SCM_PROFILE
   make_subr("scm:profile", tc7_subr_1o, scm_profile);
 #endif
-  make_specfun(s_apply, tc16_apply);
-  make_specfun(s_call_cc, tc16_call_cc);
-  make_specfun(s_eval, tc16_eval);
+  make_specfun(s_apply, tc16_apply, 0);
+  make_specfun(s_call_cc, tc16_call_cc, 0);
+  make_specfun(s_eval, tc16_eval, 0);
+  make_specfun(s_values, tc16_values, 0);
+  make_specfun(s_call_wv, tc16_call_wv, 0);
+  add_feature(s_values);
 
   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));
+  i_quasiquote = make_synt(s_quasiquote, MAC_MMACRO, m_quasiquote);
+  i_define = make_synt(s_define, MAC_MMACRO, m_define);
+  make_synt(s_delay, MAC_MMACRO, m_delay);
+
+  i_bind = CAR(sysintern("bind", UNDEFINED));
+  i_anon = CAR(sysintern("<anon>", UNDEFINED));
+  i_side_effect = CAR(sysintern("side-effect", UNDEFINED));
+  i_test = CAR(sysintern("test", UNDEFINED));
+  i_procedure = CAR(sysintern("procedure", UNDEFINED));
+  i_argument = CAR(sysintern("argument", UNDEFINED));
+  i_check_defines = CAR(sysintern("check-defines", UNDEFINED));
+  loc_atcase_aux = &CDR(sysintern("@case-aux", UNDEFINED));
 
   /* acros */
-  i_quasiquote = make_synt(s_quasiquote, makmmacro, m_quasiquote);
-  i_define = make_synt(s_define, makmmacro, m_define);
-  make_synt(s_delay, makmmacro, m_delay);
-  make_synt("defined?", makacro, definedp);
+  make_synt("defined?", MAC_ACRO, definedp);
   /* 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); */
-
-  f_apply_closure =
-    CDR(sysintern(" apply-closure",
-		  scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))")));
-
+  make_synt(s_and, MAC_MMACRO, m_and);
+  i_begin = make_synt(s_begin, MAC_MMACRO, m_begin);
+  make_synt(s_case, MAC_MMACRO, m_case);
+  make_synt(s_cond, MAC_MMACRO, m_cond);
+  make_synt(s_do, MAC_MMACRO, m_do);
+  make_synt(s_if, MAC_MMACRO, m_if);
+  i_lambda = make_synt(s_lambda, MAC_MMACRO, m_lambda);
+  i_let = make_synt(s_let, MAC_MMACRO, m_let);
+  make_synt(s_letrec, MAC_MMACRO, m_letrec);
+  make_synt(s_letstar, MAC_MMACRO, m_letstar);
+  make_synt(s_or, MAC_MMACRO, m_or);
+  i_quote = make_synt(s_quote, MAC_MMACRO, m_quote);
+  make_synt(s_set, MAC_MMACRO, m_set);
+  make_synt(s_atapply, MAC_MMACRO, m_apply);
+  /*  make_synt(s_atcall_cc, MAC_MMACRO, m_cont); */
+#ifdef MAC_INLINE
+  make_synt("@inline-lambda", MAC_MMACRO, m_inline_lambda);
+#endif
 #ifdef MACRO
   tc16_ident = newsmob(&idsmob);
   make_subr(s_renamed_ident, tc7_subr_2, renamed_ident);
-  make_synt(s_syn_quote, makmmacro, m_syn_quote);
-  make_synt("@let-syntax", makmmacro, m_atlet_syntax);
-	/* This doesn't do anything special, but might in the future. */
-  make_synt("@letrec-syntax", makmmacro, m_letrec);
-  make_synt(s_the_macro, makmmacro, m_the_macro);
-  i_mark = CAR(sysintern("let-syntax-mark", UNDEFINED));
+  make_synt(s_syn_quote, MAC_MMACRO, m_syn_quote);
+  make_synt(s_defsyntax, MAC_MMACRO, m_defsyntax);
+  make_synt(s_let_syntax, MAC_MMACRO, m_let_syntax);
+  make_synt(s_letrec_syntax, MAC_MMACRO, m_letrec_syntax);
+
+  make_synt(s_the_macro, MAC_ACRO, m_the_macro);
+#endif
+
+  f_begin = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_begin))));
+  f_define = CDR(CDR(KEYWORD_MACRO(sym2vcell(i_define))));
+
+  list_unspecified = cons(UNSPECIFIED, EOL);
+  f_evapply = cons(IM_EVAL_FOR_APPLY, EOL);
+#ifdef SCM_ENV_FILENAME
+  eval_env = scm_env_addprop(SCM_ENV_FILENAME,
+			     CAR(sysintern("eval", UNDEFINED)),
+			     EOL);
+#else
+  eval_env = EOL;
 #endif
+  f_apply_closure = scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))");
 }
diff --git a/findexec.c b/findexec.c
index b6d648b..4992775 100644
--- a/findexec.c
+++ b/findexec.c
@@ -37,54 +37,72 @@ Wed Feb 21 23:06:35 1996  Aubrey Jaffer  <jaffer@jacal.bertronics>
    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__
+#ifndef __MINGW32__
+# ifndef PLAN9
+#  include <sys/file.h>
+#  include <sys/param.h>
+# endif
+# 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
-#  include <strings.h>
+#  ifdef __sgi__
+#   include <string.h>
+#   include <stdlib.h>
+#   include <sys/stat.h>
+#   include <unistd.h>     /* for X_OK define */
+#  else
+#   ifdef PLAN9
+#    include <u.h>
+#    include <libc.h>
+#    define getcwd getwd
+#    define MAXPATHLEN 256 	/* arbitrary? */
+#    define X_OK AEXEC
+#   else
+#    include <strings.h>
+#   endif
+#  endif
+# endif
+# ifdef __amigaos__
+#  include <stdlib.h>
+#  include <sys/stat.h>
+#  include <unistd.h>
+# endif
+# ifndef __STDC__
+#  define const /**/
+# endif
+# ifdef __FreeBSD__
+/* This might be same for 44bsd derived system. */
+#  include <sys/types.h>
+#  include <sys/stat.h>
 # endif
-#endif
-#ifdef __amigados__
-# include <stdlib.h>
-# include <sys/stat.h>
-# include <unistd.h>
-#endif
-#ifndef __STDC__
-# define const /**/
-#endif
-#ifdef __FreeBSD__
+# ifdef __OpenBSD__
 /* This might be same for 44bsd derived system. */
-# include <sys/types.h>
-# include <sys/stat.h>
-#endif
-#ifdef __alpha
-# include <string.h>
-# include <stdlib.h>
-# include <sys/types.h>
-# include <sys/stat.h>
-#endif
-#ifdef GO32
-# include <sys/stat.h>
-#endif
-
-#ifndef DEFAULT_PATH
-# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts"
-#endif
+#  include <stdlib.h>
+#  include <unistd.h>
+#  include <sys/types.h>
+#  include <sys/stat.h>
+# endif
+# ifdef __alpha
+#  include <string.h>
+#  include <stdlib.h>
+#  include <sys/types.h>
+#  include <sys/stat.h>
+# endif
+# ifdef GO32
+#  include <sys/stat.h>
+# 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;
@@ -97,12 +115,12 @@ static char *copy_of(s)
 }
 
 /* ABSOLUTE_FILENAME_P(fname): True if fname is an absolute filename */
-#ifdef atarist
-# define ABSOLUTE_FILENAME_P(fname)	((fname[0] == '/') || \
+# ifdef atarist
+#  define ABSOLUTE_FILENAME_P(fname)	((fname[0] == '/') || \
 	(fname[0] && (fname[1] == ':')))
-#else
-# define ABSOLUTE_FILENAME_P(fname)	(fname[0] == '/')
-#endif /* atarist */
+# else
+#  define ABSOLUTE_FILENAME_P(fname)	(fname[0] == '/')
+# endif /* atarist */
 
 char *dld_find_executable(name)
      const char *name;
@@ -155,16 +173,21 @@ char *dld_find_executable(name)
     strcat(tbuf, name);
 
     if (access(tbuf, X_OK) == 0) {
-#ifndef hpux
-# ifndef ultrix
+# ifndef hpux
+#  ifndef ultrix
+#   ifndef __MACH__
+#    ifndef PLAN9
       struct stat stat_temp;
-      if (stat(tbuf,&stat_temp)) continue;
+      if (stat(tbuf, &stat_temp)) continue;
       if (S_IFREG != (S_IFMT & stat_temp.st_mode)) continue;
-# endif/* ultrix */
-#endif /* hpux */
+#    endif /* PLAN9 */
+#   endif /* __MACH__ */
+#  endif/* ultrix */
+# endif /* hpux */
       return copy_of(tbuf);
     }
   }
 
   return 0;
 }
+#endif /* ndef MSDOS */
diff --git a/gmalloc.c b/gmalloc.c
index f16882d..b9b5e1e 100644
--- a/gmalloc.c
+++ b/gmalloc.c
@@ -1622,11 +1622,13 @@ write to the Free Software Foundation, Inc., 59 Temple Place, Suite
 extern size_t __getpagesize PP ((void));
 #endif
 #else
+#ifndef __osf__			/* declared in <unistd.h> */
 #ifndef hpux			/* declared in <unistd.h> */
 #ifndef __svr4__		/* declared in <unistd.h> */
 #include "getpagesize.h"
 #endif
 #endif
+#endif
 #define	 __getpagesize()	getpagesize()
 #endif
 
@@ -1649,6 +1651,7 @@ valloc (size)
 
 #endif	/* Not ELIDE_VALLOC.  */
 
+#ifdef DEBUG_GMALLOC
 /* Debugging functions added by Radey Shouman */
 struct list *check_block_prev;
 int check_block(block, cont)
@@ -1697,4 +1700,4 @@ int check_frag_blocks()
     }
   return 0;
 }
-
+#endif
diff --git a/gsubr.c b/gsubr.c
index 5cdaf98..f7dd777 100644
--- a/gsubr.c
+++ b/gsubr.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -130,4 +130,5 @@ SCM gsubr_apply(args)
 void init_gsubr()
 {
   f_gsubr_apply = make_subr(s_gsubr_apply, tc7_lsubr, gsubr_apply);
+  add_feature("generalized-c-arguments");
 }
diff --git a/hobbit.info b/hobbit.info
new file mode 100644
index 0000000..9e0c0a9
--- /dev/null
+++ b/hobbit.info
@@ -0,0 +1,1952 @@
+This is hobbit.info, produced by makeinfo version 4.0 from hobbit.texi.
+
+INFO-DIR-SECTION The Algorithmic Language Scheme
+START-INFO-DIR-ENTRY
+* hobbit: (hobbit).   SCM Compiler.
+END-INFO-DIR-ENTRY
+
+
+File: hobbit.info,  Node: Top,  Next: Introduction,  Prev: (dir),  Up: (dir)
+
+Hobbit is an optimizing R4RS-Scheme to C compiler written by Tanel
+Tammet.
+
+* Menu:
+
+* Introduction::
+* Compiling with Hobbit::
+* The Language Compiled::
+* Performance of Compiled Code::
+* Principles of Compilation::
+* About Hobbit::
+
+Copyright (C) 1990-1999, 2002 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.
+
+
+File: hobbit.info,  Node: Introduction,  Next: Compiling with Hobbit,  Prev: Top,  Up: Top
+
+Introduction
+************
+
+Hobbit is a small optimizing scheme-to-C compiler written in Report 4
+scheme and intended for use together with the SCM scheme interpreter of
+A. Jaffer.  Hobbit compiles full Report 4 scheme, except that:
+
+   * It does not fully conform to the requirement of being properly
+     tail-recursive: non-mutual tailrecursion is detected, but mutual
+     tailrecursion is not.
+
+   * Macros from the Report 4 appendix are not supported (yet): only
+     the common-lisp-like defmacro is supported.
+
+Hobbit treats SCM files as a C library and provides integration of
+compiled procedures and variables with the SCM interpreter as new
+primitives.
+
+Hobbit compiles scheme files to C files and does not provide anything
+else by itself (eg. calling the C compiler, dynamic loading).  Such
+niceties are described in the next chapter *Note Compiling And
+Linking::.
+
+Hobbit (derived from hobbit5x) is now part of the SCM Scheme
+implementation.  The most recent information about SCM can be found on
+SCM's "WWW" home page:
+
+             <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
+
+Hobbit4d has also been ported to the Guile Scheme implementation:
+
+           <http://www.gnu.org/software/guile/anon-cvs.html>
+
+
+File: hobbit.info,  Node: Compiling with Hobbit,  Next: The Language Compiled,  Prev: Introduction,  Up: Top
+
+Compiling with Hobbit
+*********************
+
+* Menu:
+
+* Compiling And Linking::
+* Error Detection::
+* Hobbit Options::
+* CC Optimizations::
+
+
+File: hobbit.info,  Node: Compiling And Linking,  Next: Error Detection,  Prev: Compiling with Hobbit,  Up: Compiling with Hobbit
+
+Compiling And Linking
+=====================
+
+`(require 'compile)'
+
+ - Function: hobbit name1.scm name2.scm ...
+     Invokes the HOBBIT compiler to translate Scheme files `NAME1.scm',
+     `NAME2.scm', ... to C files `NAME1.c' and `NAME1.h'.
+
+ - Function: compile-file name1.scm name2.scm ...
+     Compiles the HOBBIT translation of NAME1.scm, NAME2.scm, ... to a
+     dynamically linkable object file NAME1<object-suffix>, where
+     <object-suffix> is the object file suffix for your computer (for
+     instance, `.so').  NAME1.scm must be in the current directory;
+     NAME2.scm, ... may be in other directories.
+
+     cd ~/scm/
+     scm -rcompile -e'(compile-file "example.scm")'
+     
+     Starting to read example.scm
+     
+     Generic (slow) arithmetic assumed: 1.0e-3 found.
+     
+     ** Pass 1 completed **
+     ** Pass 2 completed **
+     ** Pass 3 completed **
+     ** Pass 4 completed **
+     ** Pass 5 completed **
+     ** Pass 6 completed **
+     
+     C source file example.c is built.
+     C header file example.h is built.
+     
+     These top level higher order procedures are not clonable (slow):
+     (nonkeyword_make-promise map-streams generate-vector runge-kutta-4)
+     These top level procedures create non-liftable closures (slow):
+     (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system)
+     
+     ; Scheme (linux) script created by SLIB/batch Sun Apr  7 22:49:49 2002
+     ; ================ Write file with C defines
+     (delete-file "scmflags.h")
+     (call-with-output-file
+       "scmflags.h"
+       (lambda (fp)
+         (for-each
+           (lambda (string) (write-line string fp))
+           '("#define IMPLINIT \"Init5d6.scm\""
+             "#define BIGNUMS"
+             "#define FLOATS"
+             "#define ARRAYS"
+             "#define DLL"))))
+     ; ================ Compile C source files
+     (system "gcc -O2 -fpic -c -I/usr/local/lib/scm/ example.c")
+     (system "gcc -shared -o example.so example.o -lm -lc")
+     (delete-file "example.o")
+     ; ================ Link C object files
+     (delete-file "slibcat")
+     
+     Compilation finished at Sun Apr  7 22:49:50
+
+ - Function: compile->executable exename name1.scm name2.scm ...
+     Compiles and links the HOBBIT translation of NAME1.scm, NAME2.scm,
+     ... to a SCM executable named EXENAME.  NAME1.scm must be in the
+     current directory; NAME2.scm, ... may be in other directories.
+
+     cd ~/scm/
+     scm -rcompile -e'(compile->executable "exscm" "example.scm")'
+     
+     Starting to read example.scm
+     
+     Generic (slow) arithmetic assumed: 1.0e-3 found.
+     
+     ** Pass 1 completed **
+     ** Pass 2 completed **
+     ** Pass 3 completed **
+     ** Pass 4 completed **
+     ** Pass 5 completed **
+     ** Pass 6 completed **
+     
+     C source file example.c is built.
+     C header file example.h is built.
+     
+     These top level higher order procedures are not clonable (slow):
+     (nonkeyword_make-promise map-streams generate-vector runge-kutta-4)
+     These top level procedures create non-liftable closures (slow):
+     (nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system)
+     
+     ; Scheme (linux) script created by SLIB/batch Sun Apr  7 22:46:31 2002
+     ; ================ Write file with C defines
+     (delete-file "scmflags.h")
+     (call-with-output-file
+       "scmflags.h"
+       (lambda (fp)
+         (for-each
+           (lambda (string) (write-line string fp))
+           '("#define IMPLINIT \"Init5d6.scm\""
+             "#define COMPILED_INITS init_example();"
+             "#define CCLO"
+             "#define FLOATS"))))
+     ; ================ Compile C source files
+     (system "gcc -O2 -c continue.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c example.c scm.c")
+     ; ================ Link C object files
+     (system "gcc -rdynamic -o exscm continue.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o example.o scm.o -L/usr/local/lib/scm/ -lm -lc")
+     
+     Compilation finished at Sun Apr  7 22:46:44
+
+_Note Bene:_ `#define CCLO' must be present in `scmfig.h'.
+
+In order to see calls to the C compiler and linker, do
+
+     (verbose 3)
+
+before calling these functions.
+
+
+File: hobbit.info,  Node: Error Detection,  Next: Hobbit Options,  Prev: Compiling And Linking,  Up: Compiling with Hobbit
+
+Error Detection
+===============
+
+Error detection during compilation is minimal.  In case your scheme code
+is syntactically incorrect, hobbit may crash with no sensible error
+messages or it may produce incorrect C code.
+
+Hobbit does not insert any type-checking code into the C output it
+produces.  Eg, if a hobbit-compiled program applies `car' to a number,
+the program will probably crash with no sensible error messages.
+
+Thus it is strongly suggested to compile only throughly debugged scheme
+code.
+
+Alternatively, it is possible to compile all the primitives into calls
+to the SCM procedures doing type-checking.  Hobbit will do this if you
+tell it to assume that all the primitives may be redefined.  Put
+
+     (define compile-all-proc-redefined #t)
+
+anywhere in top level of your scheme code to achieve this.
+
+_Note Bene:_ The compiled code using
+
+     (define compile-all-proc-redefined #t)
+
+will typically be much slower than one produced without using
+
+     (define compile-all-proc-redefined #t).
+
+All errors caught by hobbit will generate an error message
+
+     COMPILATION ERROR:
+     <description of the error>
+
+and hobbit will immediately halt compilation.
+
+
+File: hobbit.info,  Node: Hobbit Options,  Next: CC Optimizations,  Prev: Error Detection,  Up: Compiling with Hobbit
+
+Hobbit Options
+==============
+
+  1. Selecting the type of arithmetics.
+
+     By default hobbit assumes that only immediate (ie small, up to 30
+     bits) integers are used.  It will automatically assume general
+     arithmetics in case it finds any non-immediate numbers like 1.2 or
+     10000000000000 or real-only procedures like $sin anywhere in the
+     source.
+
+     Another way to make Hobbit assume that generic arithmetic supported
+     by SCM (ie exact and/or inexact reals, bignums) is also used, is to
+     put the following line somewhere in your scheme source file:
+
+          (define compile-allnumbers T)
+
+     where T is arbitrary.
+
+     In that case all the arithmetic primitives in all the given source
+     files will be assumed to be generic.  This will make operations
+     with immediate integers much slower.  You can use the special
+     immediate-integer-only forms of arithmetic procedures to recover:
+
+          %negative?  %number?    %>      %>=     %=      %<=     %<
+          %positive?  %zero?      %eqv?   %+      %-      %*      %/
+
+     See *Note The Language Compiled::.
+
+  2. Redefinition of procedures.
+
+     By default hobbit assumes that neither primitives nor compiled
+     procedures are redefined, neither before the compiled program is
+     initialized, during its work or later via the interpreter.
+
+     Hobbit checks the compiled source and whenever some variable bar is
+     defined as a procedure, but is later redefined, or set!  is applied
+     to bar, then hobbit assumes thas this particular variable bar is
+     redefinable.  bar may be a primitive (eg `car') or a name of a
+     compiled procedure.
+
+     _Note Bene:_ According to the Report 4 it is NOT allowed to use
+     scheme keywords as variables (you may redefine these as macros
+     defined by defmacro, though):
+
+          => and begin case cond define delay do else if lambda
+          let let letrec or quasiquote quote set! unquote unquote-splicing
+
+     If you want to be able to redefine some procedures, eg. `+' and
+     `baz', then put both
+
+          (set! + +)
+          (set! baz baz)
+
+     somewhere into your file.
+
+     As a consequence hobbit will generate code for `+' and `baz' using
+     the run-time values of these variables.  This is generally much
+     slower than using non-redefined `+' and `baz' (especially for `+').
+
+     If you want to be able to redefine all the procedures, both
+     primitives (eg `car') and the compiled procedures, then put the
+     following into the compiled file:
+
+          (define compile-all-proc-redefined T)
+
+     where T is arbitrary.
+
+     If you want to be able to redefine all the compiled procedures,
+     but not the scheme primitives, then put the following into the
+     compiled file:
+
+          (define compile-new-proc-redefined T)
+
+     where T is arbitrary.
+
+     Again, remember that redefinable procedures will be typically much
+     slower than  non-redefinable procedures.
+
+  3. Inlined variables and procedures.
+
+     You may inline top-level-defined variables and procedures.  Notice
+     that inlining is DIFFERENT for variables and procedures!
+
+     NEVER inline variables or procedures which are set! or redefined
+     anywhere in you program: this will produce wrong code.
+
+        * You may declare certain top-level defined variables to be
+          inlined.  For example, if the following variable foo is
+          declared to be inlined
+
+          (define foo 100)
+
+     then `foo' will be everywhere replaced by `100'.
+
+     To declare some variables foo and bar to be inlined, put a
+     following definition anywhere into your file:
+
+          (define compile-inline-vars '(foo bar))
+
+     Usually it makes sense to inline only these variables whose value
+     is either a small integer, character or a boolean.
+
+     _Note Bene:_ Do not use this kind of inlining for inlining
+     procedures!  Use the following for procedures:
+
+        * You may declare certain procedures to be inlined.  For
+          example, if the following foo is declared to be inlined
+
+          (define (foo x) (+ x 2))
+
+     then any call
+
+          (foo SOMETHING)
+
+     will be replaced by
+
+          (+ SOMETHING 2)
+
+     Inlining is NOT safe for variable clashes - in other words, it is
+     not "hygienic".
+
+     Inlining is NOT safe for recursive procedures - if the set of
+     inlined procedures contains either immediate or mutual (foo calling
+     bar, bar calling foo) recursion, the compiler will not terminate.
+     To turn off full inlining (harmful for recursive funs), change the
+     definition of the *full-inlining-flag* in the section "compiler
+     options" to the value #f instead of #t.
+
+     To declare some procedures foo and bar to be inlined, put a
+     following definition anywhere into your file:
+
+          (define compile-inline '(foo bar))
+
+  4. Speeding up vectors:
+
+     Put
+
+          (define compile-stable-vectors '(baz foo))
+
+     into your file to declare that baz and foo are vector names
+     defined once on the top level, and set! is never applied to them
+     (vector-set!  is, of course, allowed).  This speeds up vector
+     reference to those vectors by precomputing their location.
+
+  5. Speeding up and hiding certain global variables:
+
+     Put
+
+          (define compile-uninterned-variables '(bazvar foovar))
+
+     into your file to declare that bazvar and foovar are defined on
+     the top level and they do always have an immediate value, ie a
+     boolean, immediate (30-bit) integer or a character.  Then bazvar
+     and foovar will NOT be accessible from the interpreter.  They'll
+     be compiled directly into static C vars and used without an extra
+     C *-operation prefixed to other global scheme variables.
+
+  6. Intermediate files
+
+     To see the output of compiler passes, change the following
+     definition in `hobbit.scm'.
+
+          (define *build-intermediate-files* #f)
+
+     to:
+
+          (define *build-intermediate-files* #t)
+
+  7. Name clashes
+
+     It may happen that several originally different scheme variable
+     names are represented by one and the same C variable.  This will
+     happen, for example, if you have separate variables a-1 and a_1.
+
+     If such (or any other) name clashes occur you may need to change
+     some control variables in the first sections of `hobbit.scm' (up
+     to the section "global variable defs") or just rename some
+     variables in your scheme program.
+
+  8. Other options
+
+     See various control variables in the first sections of `hobbit.scm'
+     (up to section "global variable defs").
+
+
+File: hobbit.info,  Node: CC Optimizations,  Prev: Hobbit Options,  Up: Compiling with Hobbit
+
+CC Optimizations
+================
+
+When using the C compiler to compile the C code output by hobbit, always
+use strong optimizations (eg. `cc -xO3' for cc on Sun, `gcc -O2' or
+`gcc -O3' for gcc).  Hobbit does not attempt to do optimizations of the
+kind we anticipate from the C compiler, therefore it often makes a
+serious difference whether the C compiler is run with a strong
+optimization flag or not.
+
+For the final and fast version of your program you may want to first
+recompile the whole scm (scmlit for the version scm4e2) using the
+`-DRECKLESS' flag suppressing error checking: the hobbit-compiled code
+uses some SCM primitives in the compiled files with the suffix .o, and
+a number of these primitives become faster when error checking is
+disabled by `-DRECKLESS'.  Notice that hobbit never inserts error
+checking into the code it produces.
+
+
+File: hobbit.info,  Node: The Language Compiled,  Next: Performance of Compiled Code,  Prev: Compiling with Hobbit,  Up: Top
+
+The Language Compiled
+*********************
+
+Calls to `load' or `require' occurring at the top level of a file being
+compiled are ignored.  Calls to `load' or `require' within a procedure
+are compiled to call (interpreted) `load' or `require' as appropriate.
+
+Several SCM and SLIB extensions to the Scheme report are recognized by
+hobbit as Scheme primitives.
+
+* Menu:
+
+* Macros::
+* SCM Primitive Procedures::
+* SLIB Logical Procedures::
+* Fast Integer Calculations::
+* Force and Delay::
+* Suggestions for writing fast code::
+
+
+File: hobbit.info,  Node: Macros,  Next: SCM Primitive Procedures,  Prev: The Language Compiled,  Up: The Language Compiled
+
+Macros
+======
+
+The Common-lisp style defmacro implemented in SCM is recognized and
+procedures defined by defmacro are expanded during compilation.
+
+_Note Bene:_ any macro used in a compiled file must be also defined in
+one of the compiled files.
+
+`#.<EXPRESSION>' is read as the object resulting from the evaluation of
+<EXPRESSION>.  The calculation is performed during compile time.  Thus
+<EXPRESSION> must not contain variables defined or set! in the compiled
+file.
+
+
+File: hobbit.info,  Node: SCM Primitive Procedures,  Next: SLIB Logical Procedures,  Prev: Macros,  Up: The Language Compiled
+
+SCM Primitive Procedures
+========================
+
+Real-only versions of transcedental procedures (warning: these
+procedures are not compiled directly into the corresponding C library
+procedures, but a combination of internal SCM procedures, guaranteeing
+exact correspondence with the SCM interpreter while hindering the
+speed):
+
+     $sqrt $abs $exp $log $sin $cos $tan $asin $acos
+     $atan $sinh $cosh $tanh $asinh $acosh $atanh $expt
+
+_Note Bene:_ These procedures are compiled to faster code than the
+corresponding generic versions sqrt, abs, ... expt.
+
+A selection of other extra primitives in SCM is also recognized as
+primitives. eg. get-internal-run-time, quit, abort, restart, chdir,
+delete-file, rename-file.
+
+
+File: hobbit.info,  Node: SLIB Logical Procedures,  Next: Fast Integer Calculations,  Prev: SCM Primitive Procedures,  Up: The Language Compiled
+
+SLIB Logical Procedures
+=======================
+
+The following bitwise procedures in the scheme library file
+`logical.scm' are compiled directly to fast C operations on immediate
+integers (small 30-bit integers) (Scheme library funs in the upper row,
+C ops below):
+
+        logand logior logxor lognot logsleft logsright
+           &      |     ^      ~       <<        >>
+
+The following alternative names logical:logand, logical:logior,
+logical:logxor, logical:lognot, ash, logical:ash are compiled for the
+generic case, not immediate-integers-only and are thus much slower.
+
+Notice that the procedures logsleft, logsright are NOT in the the
+library file `logical.scm:' the universal procedure ash is instead.
+Procedures ash, logcount, integer-length, integer-expt, bit-extract,
+ipow-by-squaring, logical:ash, logical:logcount, logical:integer-length,
+logical:integer-expt, logical:bit-extract, logical:ipow-by-squaring, in
+`logical.scm' are not primtives and they are all compiled into calls to
+interpreted code.
+
+logsleft and logsright are defined for non-compiled use in the file
+`scmhob.scm' included in the SCM distribution.
+
+
+File: hobbit.info,  Node: Fast Integer Calculations,  Next: Force and Delay,  Prev: SLIB Logical Procedures,  Up: The Language Compiled
+
+Fast Integer Calculations
+=========================
+
+The following primitives are for immediate (30-bit) integer-only
+arithmetics.  The are compiled directly into the corresponding C
+operations plus some bitshifts if necessary.  They are good for speed in
+case the compiled program uses BOTH generic arithmetics (reals, bignums)
+and immediate (30-bit) integer arithmetics.  These procedures are much
+faster than corresponding generic procedures taking also reals and
+bignums.  There is no point in using these unless the program as a whole
+is compiled using generic arithmetics, since otherwise all the
+arithmetics procedures are compiled directly into corresponding C
+operations anyway.
+
+_Note Bene:_ These primitives are NOT defined in SCM or its libraries.
+For non-compiled use they are defined in the file `scmhob.scm' included
+in the SCM distribution.
+
+     %negative?  %number?    %>      %>=     %=      %<=     %<
+     %positive?  %zero?      %eqv?   %+      %-      %*      %/
+
+
+File: hobbit.info,  Node: Force and Delay,  Next: Suggestions for writing fast code,  Prev: Fast Integer Calculations,  Up: The Language Compiled
+
+Force and Delay
+===============
+
+The nonessential procedure `force' and syntax `delay' are implemented
+exactly as suggested in the report 4.  This implementation deviates
+internally from the implementation of `force' and `delay' in the SCM
+interpeter, thus it is incorrect to pass a promise created by `delay'
+in the compiled code to the `force' used by interpreter, and vice-versa
+for the promises created by the interpreter.
+
+
+File: hobbit.info,  Node: Suggestions for writing fast code,  Prev: Force and Delay,  Up: The Language Compiled
+
+Suggestions for writing fast code
+=================================
+
+The following suggestions may help you to write well-optimizable and
+fast code for the hobbit-scm combination.  Roughly speaking, the main
+points are:
+
+   * minimizing consing and creation of new vectors and strings in
+     speed-critical parts,
+
+   * minimizing the use of generic (non-integer) arithmetics in
+     speed-critical parts,
+
+   * minimizing the usage of procedures as first-class objects (very
+     roughly speaking, explicit lambda-terms and call/cc) in
+     speed-critical parts,
+
+   * using special options and fast-compiled primitives of the compiler.
+
+Here come the details.
+
+  1. Immediate arithmetics (ie using small, up to 30 bits integers) is
+     much faster than generic (reals and bignums) arithmetics.  If you
+     have to use generic arithmetic in your program, then try to use
+     special immediate arithmetics operations `%=', `%<=', `%+', `%*',
+     ... for speed-critical parts of the program whenever possible.
+
+     Also, if you use bitwise logical operations, try to use the
+     immediate-integer-only versions
+
+          logand logior logxor lognot logsleft logsright
+
+     and not `logical:logand' or `ash', for example.
+
+  2. Due to its inner stack-based architecture, the generic (not
+     escape-only) continuations are very slow in SCM.  Thus they are
+     also slow in compiled code.  Try to avoid continuations  (calls to
+     the procedure call-with-current-continuation and calls to the
+     continuations it produces) in speed-critical parts.
+
+  3. In speed-critical parts of your program try to avoid using
+     procedures which are redefined or defined by set!:
+
+          (set! bar +)
+          (set! f (lambda (x) (if (zero? x) 1 (* x (f (- x 1))))))
+
+     anywhere in the compiled program.  Avoid using compiler flags
+     (*note Hobbit Options::):
+
+          (define compile-all-proc-redefined T)
+          (define compile-new-proc-redefined T)
+
+  4. Do not use complicated higher-order procedures in speed-critical
+     parts.  By "complicated" we mean "not clonable", where clonability
+     is defined in the following way (_Note Bene:_ the primitives `map'
+     and `for-each' are considered clonable and do not inflict a speed
+     penalty).
+
+     A higher-order procedure (HOP for short) is defined as a procedure
+     with some of its formal arguments occuring in the procedure body in
+     a function position, that is, as a first element of a list.  Such
+     an argument is called a "higher-order argument".
+
+     A HOP `bar' is clonable iff it satisfies the following four
+     conditions:
+
+       1. `bar' is defined as
+
+               (define bar (lambda ...))
+
+          or
+
+               (define (bar ...) ...)
+
+          on top level and bar is not redefined anywhere.
+
+       2. the name `bar' occurs inside the body of bar only in a
+          function position and not inside an internal lambda-term.
+
+       3. Let f be a higher-order argument of bar.  Any occurrence of f
+          in bar has one of the following two forms:
+
+             * f occurs in a function position,
+
+             * f is passed as an argument to bar and in the call it
+               occurs in the same position as in the argument list.
+
+       4. Let f be a higher-order argument of bar.  f does not occur
+          inside a lambda-term occurring in bar.
+
+          Examples:
+
+          If `member-if' is defined on top level and is not redefined
+          anywhere, then `member-if' is a clonable HOP:
+
+               (define (member-if fn lst)
+                  (if (fn (car lst))
+                      lst
+                      (member-if fn (cdr lst)) ))
+
+          member-if-not is not a clonable HOP (fn occurs in a
+          lambdaterm):
+
+               (define (member-if-not fn lst)
+                 (member (lambda (x) (not (fn x))) lst) )
+
+          show-f is not a clonable HOP (fn occurs in a non-function
+          position in (display fn)):
+
+               (define (show-f fn x)
+                   (set! x (fn x))
+                   (display fn)
+                   x)
+
+       5. In speed-critical parts avoid using procedures which return
+          procedures.
+
+          Eg, a procedure
+
+               (define plus
+                 (lambda (x)
+                    (lambda (y) (+ y x)) ))
+
+          returns a procedure.
+
+       6. A generalisation of the previous case 5:
+
+          In speed-critical parts avoid using lambda-terms except in
+          non-set!  function definitions like
+
+               (define foo (lambda ...)),
+               (let ((x 1) (f (lambda ...))) ...)
+               (let* ((x 1) (f (lambda ...))) ...)
+               (let name ((x 1) (f (lambda ...))) ...)
+               (letrec ((f (lambda ...)) (g (lambda ...))) ...)
+
+          or as arguments to clonable HOP-s or primitives map and
+          for-each, like
+
+               (let ((x 0)) (map (lambda (y) (set! x (+ 1 x)) (cons x y)) LIST))
+               (member-if (lambda (x) (< x 0)) LIST)
+
+          where member-if is a clonable HOP.
+
+          Also, avoid using variables with a procedural value anywhere
+          except in a function position (first element of a list) or as
+          an argument to a clonable HOP, map or for-each.
+
+          Lambda-terms conforming to the current point are said to be
+          liftable.
+
+          Examples:
+
+               (define (bar x) (let ((f car)) (f (f x))))
+
+          has `car' in a non-function and non-HOP-argument position in
+          `(f car)', thus it is slower than
+
+               (define (bar x) (let ((f 1)) (car (car x))))
+
+          Similarly,
+
+               (define (bar y z w)
+                 (let ((f (lambda (x) (+ x y))))
+                    (set! w f)
+                    (cons (f (car z))
+                          (map f z) )))
+
+          has `f' occurring in a non-function position in `(set! w f)',
+          thus the lambda-term `(lambda (x) (+ x y))' is not liftable
+          and the upper `bar' is thus slower than the following
+          equivalent `bar' with a liftable inner lambda-term:
+
+               (define (bar y z w)
+                 (let ((f (lambda (x) (+ x y))))
+                    (set! w 0)
+                    (cons (f (car z))
+                          (map f z) )))
+
+          Using a procedure bar defined as
+
+               (define bar (let ((x 1)) (lambda (y) (set! x y) (+ x y))))
+
+          is slower than using a procedure bar defined as
+
+               (define *bar-x* 1)
+               (define bar (lambda (y) (set! *bar-x* y) (+ *bar-x* y)))
+
+          since the former definition contains a non-liftable
+          lambda-term.
+
+       7. Try to minimize the amount of consing in the speed-critical
+          program fragments, that is, a number of applications of cons,
+          list, map, quasiquote (`) and vector->list during the time
+          program is running.  `cons' (called also by `list', `map' and
+          `quasiquote') is translated into a C call to an internal cons
+          procedure of the SCM interpreter.  Excessive consing also
+          means that the garbage collection happens more often.  Do
+          `(verbose 3)' to see the amount of time used by garbage
+          collection while your program is running.
+
+          Try to minimize the amount of creating new vectors, strings
+          and symbols in the speed-critical program frgaments, that is,
+          a number of applications of make-vector, vector, list->vector,
+          make-string, string-append, *->string, string->symbol.
+          Creating such objects takes typically much more time than
+          consing.
+
+       8. The Scheme iteration construction `do' is compiled directly
+          into the C iteration construction `for'.  We can expect that
+          the C compiler has some knowledge about `for' in the
+          optimization stage, thus it is probably faster to use `do'
+          for iteration than non-mutual tailrecursion (which is
+          recognized by hobbit as such and is compiled into a jump to a
+          beginning of a procedure) and certainly much faster than
+          non-tail-recursion or mutual tailrecursion (the latter is not
+          recognized by hobbit as such).
+
+       9. Declare small nonrecursive programs which do not contain
+          let-s or lambdaterms as being inlinable.
+
+          Declare globally defined variables which are never set! or
+          redefined and whose value is a small integer, character or a
+          boolean, as being inlinable.  *Note Hobbit Options::.
+
+      10. If possible, declare vectors as being stable.  *Note Speeding
+          up vectors: Hobbit Options.  This gives a minor improvement
+          in speed.
+
+      11. If possible, declare critical global vars as being uninterned.
+          *Note Speeding up and hiding certain global variables: Hobbit
+          Options.  This gives a minor improvement in speed.  Declare
+          the global variables which are never set! and have an
+          (unchanged) numeric or boolean value as being inlined.  *Note
+          Hobbit Options::.
+
+     In addition, take the following into account:
+
+        * When using the C compiler to compile the C code output by
+          hobbit, always use strong optimizations (eg. `cc -xO3' for cc
+          on Sun, `gcc -O2' or `gcc -O3' for gcc).  Hobbit does not
+          attempt to do optimizations of the kind we anticipate from
+          the C compiler, therefore it often makes a big difference if
+          the C compiler is run with a strong optimization flag or not.
+
+        * hobbit does not give proper tailrecursion behaviour for mutual
+          tailrecursion (foo calling bar, bar calling foo
+          tailrecursively).
+
+          Hobbit guarantees proper tailrecursive behaviour for
+          non-mutual tailrecursion (foo calling foo tailrecursively),
+          provided that foo is not redefined anywhere and that foo is
+          not a local function which occurs also in a non-function and
+          non-clonable-HOP-argument position (i.e. cases 3 and 6 above).
+
+
+File: hobbit.info,  Node: Performance of Compiled Code,  Next: Principles of Compilation,  Prev: The Language Compiled,  Up: Top
+
+Performance of Compiled Code
+****************************
+
+* Menu:
+
+* Gain in Speed::
+* Benchmarks::
+* Benchmark Sources::
+
+
+File: hobbit.info,  Node: Gain in Speed,  Next: Benchmarks,  Prev: Performance of Compiled Code,  Up: Performance of Compiled Code
+
+Gain in Speed
+=============
+
+The author has so far compiled and tested a number of large programs
+(theorem provers for various logics and hobbit itself).
+
+The speedup for the provers was between 25 and 40 times for various
+provable formulas.  Comparison was made between the provers being
+interpreted and compiled with `gcc -O2 -DRECKLESS' on Sparcstation ELC
+in both cases.
+
+The provers were written with care to make the compiled version run
+fast.  They do not perform excessive consing and they perform very
+little arithmetic.
+
+According to experiments made by A. Jaffer, the compiled form of the
+example program `pi.scm' was approximately 11 times faster than the
+interpreted form.
+
+As a comparison, his hand-coded C program for the same algorithm of
+computing pi was about 12 times faster than the interpreted form.
+`pi.scm' spends most of of its time in immediate arithmetics,
+vector-ref and vector-set!.
+
+P. Kelloma"ki has reported a 20-fold speedup for his generic scheme
+debugger.  T. Moore has reported a 16-fold speedup for a large
+gate-level IC optimizer.
+
+Self-compilation speeds Hobbit up only ca 10 times.
+
+However, there are examples where the code compiled by hobbit runs
+actually slower than the same code running under interpreter: this may
+happen in case the speed of the code relies on non-liftable closures
+and proper mutual tailrecursion.  See for example the closure-intensive
+benchmark CPSTAK in the following table.
+
+
+File: hobbit.info,  Node: Benchmarks,  Next: Benchmark Sources,  Prev: Gain in Speed,  Up: Performance of Compiled Code
+
+Benchmarks
+==========
+
+We will present a table with the performance of three scheme systems on
+a number of benchmarks: interpreted SCM, byte-compiled VSCM and
+hobbit-compiled code.  The upper 13 benchmarks of the table are the
+famous Gabriel benchmarks (originally written for lisp) modified for
+scheme by Will Clinger.  The lower five benchmarks of the table are
+proposed by other people.  "Selfcompile" is the self-compile time of
+Hobbit.
+
+Hobbit performs well on most of the benchmarks except CPSTAK and CTAK:
+CPSTAK is a closure-intensive tailrecursive benchmark and CTAK is a
+continuations-intensive benchmark.  Hobbit performs extremely well on
+these benchmarks which essentially satisfy the criterias for
+well-optimizable code outlined in the section 6 above.
+
+FFT is real-arithmetic-intensive.
+
+All times are in seconds.
+
+SCM 4c0(U) and 1.1.5*(U) (the latter is the newest version of VSCM) are
+compiled and run by Matthias Blume on a DecStation 5000 (Ultrix).  VSCM
+is a bytecode-compiler using continuation-passing style, and is well
+optimized for continuations and closures.
+
+SCM 4e2(S) and Hobbit4b(S) compiled (with `cc -xO3') and run by Tanel
+Tammet on a Sun SS10 (lips.cs.chalmers.se).  Hobbit is a Scheme-to-C
+compiler for SCM, the code it produces does not do any checking.  SCM
+and hobbit are not optimized for continuations.  Hobbit is not
+optimized for closures and proper mutual tailrecursion.
+
+SCM and Hobbit benchmarks were run giving ca 8 MB of free heap space
+before each test.
+
+     Benchmark       |SCM 4c0(U) 1.1.5*(U)| SCM 4e2(S)  Hobbit4b(S)
+     ----------------|------------------------------------------------
+     Deriv           | 3.40      3.86     |  2.9            0.18
+     Div-iter        | 3.45      2.12     |  2.6            0.083
+     Div-rec         | 3.45      2.55     |  3.5            0.42
+     TAK             | 1.81      1.71     |  1.4            0.018
+     TAKL            |14.50     11.32     | 13.8(1.8 in gc) 0.13
+     TAKR            | 2.20      1.64     |  1.7 1.5        0.018
+     Destruct        | ?          ?       |  7.4(1.8 in gc) 0.18
+     Boyer           | ?          ?       | 27.(3.8 in gc)  1.9
+     CPSTAK          | 2.72      2.64     |  2.0 1.92       3.46(2.83 in gc)
+     CTAK            |31.0       4.11     | memory          memory
+     CTAK(7 6 1)     | ?          ?       |  0.83           0.74
+     FFT             |12.45     15.7      | 11.4 10.8       1.0
+     Puzzle          | 0.28      0.41     |  0.46(0.22 gc)  0.03
+     ----------------------------------------------------------------
+     (recfib 25)     | ?          ?       |  4.1            0.079
+     (recfib 30)     | ?          ?       | 55. (10.in gc)  0.87
+     (pi 300 3)      | ?          ?       |  7.4            0.46
+     (hanoi 15)      | ?          ?       |  0.68           0.007
+     (hanoi 20)      | ?          ?       | 31. (9. in gc)  0.2
+     ----------------------------------------------------------------
+
+
+File: hobbit.info,  Node: Benchmark Sources,  Prev: Benchmarks,  Up: Performance of Compiled Code
+
+Benchmark Sources
+=================
+
+A selection of (smaller) benchmark sources
+------------------------------------------
+
+* Menu:
+
+* Destruct::
+* Recfib::
+* div-iter and div-rec::
+* Hanoi::
+* Tak::
+* Ctak::
+* Takl::
+* Cpstak::
+* Pi::
+
+
+File: hobbit.info,  Node: Destruct,  Next: Recfib,  Prev: Benchmark Sources,  Up: Benchmark Sources
+
+Destruct
+--------
+
+     ;;;; Destructive operation benchmark
+     (define (destructive n m)
+       (let ((l (do ((i 10 (- i 1))
+                     (a '() (cons '() a)))
+                    ((= i 0) a))))
+         (do ((i n (- i 1)))
+             ((= i 0))
+           (if (null? (car l))
+               (do ((l l (cdr l)))
+                   ((null? l))
+                 (or (car l) (set-car! l (cons '() '())))
+                 (append! (car l) (do ((j m (- j 1))
+                                       (a '() (cons '() a)))
+                                      ((= j 0) a))))
+               (do ((l1 l (cdr l1))
+                    (l2 (cdr l) (cdr l2)))
+                   ((null? l2))
+                 (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
+                                (a (car l2) (cdr a)))
+                               ((zero? j) a)
+                             (set-car! a i))
+                           (let ((n (quotient (length (car l1)) 2)))
+                             (cond ((= n 0) (set-car! l1 '()) (car l1))
+                                   (else (do ((j n (- j 1))
+                                              (a (car l1) (cdr a)))
+                                             ((= j 1)
+                                              (let ((x (cdr a)))
+                                                (set-cdr! a '()) x))
+                                           (set-car! a i)))))))))))
+     ;; call:  (destructive 600 50)
+
+
+File: hobbit.info,  Node: Recfib,  Next: div-iter and div-rec,  Prev: Destruct,  Up: Benchmark Sources
+
+Recfib
+------
+
+     (define (recfib x)
+       (if (< x 2)
+           x
+           (+ (recfib (- x 1))
+              (recfib (- x 2)))))
+
+
+File: hobbit.info,  Node: div-iter and div-rec,  Next: Hanoi,  Prev: Recfib,  Up: Benchmark Sources
+
+div-iter and div-rec
+--------------------
+
+     ;;;; Recursive and iterative benchmark divides by 2 using lists of ()'s.
+     (define (create-n n)
+       (do ((n n (- n 1))
+            (a '() (cons '() a)))
+           ((= n 0) a)))
+     (define *ll* (create-n 200))
+     (define (iterative-div2 l)
+       (do ((l l (cddr l))
+            (a '() (cons (car l) a)))
+           ((null? l) a)))
+     (define (recursive-div2 l)
+       (cond ((null? l) '())
+             (else (cons (car l) (recursive-div2 (cddr l))))))
+     (define (test-1 l)
+       (do ((i 300 (- i 1))) ((= i 0))
+         (iterative-div2 l)
+         (iterative-div2 l)
+         (iterative-div2 l)
+         (iterative-div2 l)))
+     (define (test-2 l)
+       (do ((i 300 (- i 1))) ((= i 0))
+         (recursive-div2 l)
+         (recursive-div2 l)
+         (recursive-div2 l)
+         (recursive-div2 l)))
+     ;; for the iterative test call: (test-1 *ll*)
+     ;; for the recursive test call: (test-2 *ll*)
+
+
+File: hobbit.info,  Node: Hanoi,  Next: Tak,  Prev: div-iter and div-rec,  Up: Benchmark Sources
+
+Hanoi
+-----
+
+     ;;; C optimiser should be able to remove the first recursive call to
+     ;;; move-them.  But Solaris 2.4 cc, gcc 2.5.8, and hobbit don't.
+     (define (hanoi n)
+       (letrec ((move-them
+                 (lambda (n from to helper)
+                   (if (> n 1)
+                       (begin
+                         (move-them (- n 1) from helper to)
+                         (move-them (- n 1) helper to from))))))
+         (move-them n 0 1 2)))
+
+
+File: hobbit.info,  Node: Tak,  Next: Ctak,  Prev: Hanoi,  Up: Benchmark Sources
+
+Tak
+---
+
+     ;;;; A vanilla version of the TAKeuchi function
+     (define (tak x y z)
+       (if (not (< y x))
+           z
+           (tak (tak (- x 1) y z)
+                (tak (- y 1) z x)
+                (tak (- z 1) x y))))
+     ;; call: (tak 18 12 6)
+
+
+File: hobbit.info,  Node: Ctak,  Next: Takl,  Prev: Tak,  Up: Benchmark Sources
+
+Ctak
+----
+
+     ;;;; A version of the TAK function that uses continuations
+     (define (ctak x y z)
+       (call-with-current-continuation
+        (lambda (k)
+          (ctak-aux k x y z))))
+     
+     (define (ctak-aux k x y z)
+       (cond ((not (< y x)) (k z))
+             (else (call-with-current-continuation
+                    (ctak-aux
+                     k
+                     (call-with-current-continuation
+                      (lambda (k) (ctak-aux k (- x 1) y z)))
+                     (call-with-current-continuation
+                      (lambda (k) (ctak-aux k (- y 1) z x)))
+                     (call-with-current-continuation
+                      (lambda (k) (ctak-aux k (- z 1) x y))))))))
+     
+     (define (id x) x)
+     
+     (define (mb-test r x y z)
+       (if (zero? r)
+           (ctak x y z)
+           (id (mb-test (- r 1) x y z))))
+     ;;; call: (ctak 18 12 6)
+
+
+File: hobbit.info,  Node: Takl,  Next: Cpstak,  Prev: Ctak,  Up: Benchmark Sources
+
+Takl
+----
+
+     ;;;; The TAKeuchi function using lists as counters.
+     (define (listn n)
+       (if (not (= 0 n))
+           (cons n (listn (- n 1)))
+           '()))
+     
+     (define l18 (listn 18))
+     (define l12 (listn 12))
+     (define l6 (listn 6))
+     
+     (define (mas x y z)
+       (if (not (shorterp y x))
+           z
+           (mas (mas (cdr x) y z)
+                (mas (cdr y) z x)
+                (mas (cdr z) x y))))
+     
+     (define (shorterp x y)
+       (and (pair? y) (or (null? x) (shorterp (cdr x) (cdr y)))))
+     ;; call: (mas l18 l12 l6)
+
+
+File: hobbit.info,  Node: Cpstak,  Next: Pi,  Prev: Takl,  Up: Benchmark Sources
+
+Cpstak
+------
+
+     ;;;; A continuation-passing version of the TAK benchmark.
+     (define (cpstak x y z)
+       (define (tak x y z k)
+         (if (not (< y x))
+             (k z)
+             (tak (- x 1)
+                  y
+                  z
+                  (lambda (v1)
+                    (tak (- y 1)
+                         z
+                         x
+                         (lambda (v2)
+                           (tak (- z 1)
+                                x
+                                y
+                                (lambda (v3)
+                                  (tak v1 v2 v3 k)))))))))
+       (tak x y z (lambda (a) a)))
+     ;;; call: (cpstak 18 12 6)
+
+
+File: hobbit.info,  Node: Pi,  Prev: Cpstak,  Up: Benchmark Sources
+
+Pi
+--
+
+     (define (pi n  . args)
+           (let* ((d (car args))
+                  (r (do ((s 1 (* 10 s))
+                          (i 0 (+ 1 i)))
+                         ((>= i d) 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)))
+
+
+File: hobbit.info,  Node: Principles of Compilation,  Next: About Hobbit,  Prev: Performance of Compiled Code,  Up: Top
+
+Principles of Compilation
+*************************
+
+* Menu:
+
+* Macro-Expansion and Analysis::  Pass 1
+* Building Closures::           Pass 2
+* Lambda-lifting::              Pass 3
+* Statement-lifting::           Pass 4
+* Higher-order Arglists::       Pass 5
+* Typing and Constants::        Pass 6
+
+
+File: hobbit.info,  Node: Macro-Expansion and Analysis,  Next: Building Closures,  Prev: Principles of Compilation,  Up: Principles of Compilation
+
+Expansion and Analysis
+======================
+
+  1. Macros defined by defmacro and all the quasiquotes are expanded
+     and compiled into equivalent form without macros and quasiquotes.
+
+     For example, `(a , x) will be converted to (cons 'a (cons x '())).
+
+  2. Define-s with the nonessential syntax like
+
+          (define (foo x) ...)
+
+     are converted to defines with the essential syntax
+
+          (define foo (lambda (x) ...))
+
+     Non-top-level defines are converted into equivalent letrec-s.
+
+  3. Variables are renamed to avoid name clashes, so that any local
+     variable may have a whole procedure as its scope.  This renaming
+     also converts let-s to let*-s.  Variables which do not introduce
+     potential name clashes are not renamed.  For example,
+
+          (define (foo x y)
+             (let ((x y)
+                   (z x))
+               (let* ((x (+ z x)))
+                 x)))
+
+     is converted to
+
+          (define foo
+            (lambda (x y)
+              (let* ((x__1 y)
+                     (z x)
+                     (x__2 (+ z x__1)))
+                 x__2)))
+
+  4. In case the set of procedures defined in one letrec is actually not
+     wholly mutually recursive (eg, f1 calls f2, but f2 does not call
+     f1, or there are three procedures, f1, f2, f3 so that f1 and f2
+     are mutually recursive but f3 is not called from f1 or f2 and it
+     does not call them, etc), it is possible to minimize the number of
+     additional variables passed to procedures.
+
+     Thus letrec-s are split into ordered chunks using dependency
+     analysis and topological sorting, to reduce the number of mutually
+     passed variables.  Wherever possible, letrec-s are replaced by
+     let*-s inside these chunks.
+
+  5. Normalization is performed.  This converts a majority of scheme
+     control procedures like cond, case, or, and into equivalent terms
+     using a small set of primitives.  New variables may be introduced
+     in this phase.
+
+     In case a procedure like or or and occurs in the place where its
+     value is treated as a boolean (eg. first argument of if), it is
+     converted into an analogous boolean-returning procedure, which
+     will finally be represented by an analogous C procedure (eg. || or
+     &&).
+
+     Associative procedures are converted into structures of
+     corresponding nonassociative procedures.  List is converted to a
+     structure of cons-s.
+
+     Map and for-each with more than two arguments are converted into an
+     equivalent do-cycle.  map-s and for-each-s with two arguments are
+     treated as if they were defined in the compiled file - the
+     definitions map1 and for-each1 are automatically included, if
+     needed.
+
+     There is an option in `hobbit.scm' to make all map-s and
+     for-each-s be converted into equivalent do-loops, avoiding the use
+     of map1 and/or for-each1 altogether.
+
+  6. Code is analysed for determining which primitive names and
+     compiled procedure names are assumed to be redefinable.
+
+  7. Analysing HOP clonability: hobbit will find a list of clonable
+     HOP-s with information about higher-order arguments.
+
+     Criterias for HOP clonability are given in the section 6.4.
+
+  8. Analysis of liftability: hobbit will determine which lambda-terms
+     have to be built as real closures (implemented as a vector where
+     the first element is a pointer to a function and the rest contain
+     values of environment variables or environment blocks of
+     surrounding code) and which lambda-terms are liftable.
+
+     Liftability analysis follows the criterias given in section 6.5 and
+     6.6.
+
+
+File: hobbit.info,  Node: Building Closures,  Next: Lambda-lifting,  Prev: Macro-Expansion and Analysis,  Up: Principles of Compilation
+
+Building Closures
+=================
+
+Here Hobbit produces code for creating real closures for all the
+lambda-terms which are not marked as being liftable by the previous
+liftability analysis.
+
+Global variables (eg x-glob) are translated as pointers (locations) to
+SCM objects and used via a fetch: *x_glob (or a fetch macro
+GLOBAL(x-glob) which translates to *x_glob).
+
+While producing closures hobbit tries to minimize the indirection
+levels necessary.  Generally a local variable x may have to be
+translated to an element of a vector of local variables built in the
+procedure creating x.  If x occurs in a non-liftable closure, the whole
+vector of local variables is passed to a closure.
+
+Such a translation using a local vector will only take place if either x
+is set! inside a non-liftable lambda-term or x is a name of a
+recursively defined non-liftable function, and the definition of x is
+irregular.  The definition of x is irregular if x is given the
+non-liftable recursive value T by extra computation, eg as
+
+     (set! x (let ((u 1)) (lambda (y) (display u) (x (+ u 1)))))
+
+and not as a simple lambdaterm:
+
+     (set! x (lambda (y) (display x) (x (+ y 1))))
+
+In all the other cases a local scheme variable x is translated directly
+to a local C variable x having the type SCM (a 32-bit integer).  If
+such an x occurs in a non-liftable closure, then only its value is
+passed to a closure via the closure-vector.  In case the
+directly-translated variable x is passed to a liftable lambda-term
+where it is set!, then x is passed indirectly by using its address &x.
+In the lifted lambda-term it is then accessed via *.
+
+If all the variables x1, ..., xn created in a procedure can be
+translated directly as C variables, then the procedure does not create a
+special vector for (a subset of) local variables.
+
+An application (foo ...) is generally translated to C by an internal
+apply of the SCM interpreter: apply(GLOBAL(foo), ...).  Using an
+internal apply is much slower than using direct a C function call,
+since:
+
+   * there is an extra fetch by GLOBAL(foo),
+
+   * internal apply performs some computations,
+
+   * the arguments of foo are passed as a list constructed during
+     application: that is, there is a lot of expensive consing every
+     time foo is applied via an internal apply.
+
+However, in case foo is either a name of a non-redefined primitive or a
+name of a non-redefined liftable procedure, the application is
+translated to C directly without the extra layer of calling apply:
+foo(...).
+
+Sometimes lambda-lifting generates the case that some variable x is
+accessed not directly, but by *x.  See the next section.
+
+Undefined procedures are assumed to be defined via interpreter and are
+called using an internal apply.
+
+
+File: hobbit.info,  Node: Lambda-lifting,  Next: Statement-lifting,  Prev: Building Closures,  Up: Principles of Compilation
+
+Lambda-lifting
+==============
+
+When this pass starts, all the real (nonliftable) closures have been
+translated to closure-creating code.  The remaining lambda-terms are
+all liftable.
+
+Lambda-lifting is performed.  That is, all procedures defined inside
+some other procedure (eg. in letrec) and unnamed lambda-terms are made
+top-level procedure definitions.  Any N variables not bound in such
+procedures which were bound in the surrounding procedure are given as
+extra N first parameters of the procedure, and whenever the procedure is
+called, the values of these variables are given as extra N first
+arguments.
+
+For example:
+
+     (define foo
+       (lambda (x y)
+          (letrec ((bar (lambda (u) (+ u x))))
+             (bar y) )))
+
+is converted to
+
+     (define foo
+       (lambda (x y)
+         (foo-fn1 x y) ))
+     
+     (define foo-fn1
+       (lambda (x u)
+         (+ u x) ))
+
+The case of mutually recursive definitions in letrec needs special
+treatment - all free variables in mutually recursive funs have, in
+general, to be passed to each of those funs.  For example, in
+
+     (define (foo x y z i)
+       (letrec ((f1 (lambda (u) (if x (+ (f2 u) 1))))
+                (f2 (lambda (v) (if (zero? v) 1 (f1 z)))) )
+         (f2 i) ))
+
+the procedure f1 contains a free variable x and the procedure f2
+contains a free variable z.  Lambda-lifted f1 and f2 must each get both
+of these variables:
+
+     (define (foo x y z i)
+        (foo-fn2 x z i) )
+     
+     (define foo-fn1
+       (lambda (x z u) (if x (+ (foo-fn2 x z u) 1))) )
+     
+     (define foo-fn2
+       (lambda (x z v) (if (zero? v) 1 (foo-fn1 x z z))) )
+
+Recall that hobbit has already done dependency analysis and has split
+the original letrec into smaller chunks according to this analysis: see
+pass 1.
+
+Whenever the value of some free variable is modified by set! in the
+procedure, this variable is passed by reference instead.  This is not
+directly possible in scheme, but it is possible in C.
+
+     (define foo
+       (lambda (x y z)
+          (letrec ((bar (lambda (u) (set! z (+ u x z)))))
+             (bar y)
+             z)))
+
+is converted to incorrect scheme:
+
+     (define foo
+       (lambda (x y z)
+         (foo-fn1 x (**c-adr** z) y)
+         z))
+     
+     (define foo-fn1
+       (lambda (x (**c-adr** z) u)
+         (set! (**c-fetch** z) (+ u x (**c-fetch** z))) ))
+
+The last two will finally be compiled into correct C as:
+
+     SCM foo(x, y, z)
+     SCM x, y, z;
+     {
+       foo_fn1(x, &z, y);
+       return z;
+     }
+     
+     SCM foo_fn1(x, z, u)
+     SCM x, u;
+     SCM *z;
+     {
+       return (*z =  (u + x) + *z);
+     }
+
+
+File: hobbit.info,  Node: Statement-lifting,  Next: Higher-order Arglists,  Prev: Lambda-lifting,  Up: Principles of Compilation
+
+Statement-lifting
+=================
+
+As the scheme do-construction is compiled into C for, but for cannot
+occur in all places in C (it is a statement), then if the do in a
+scheme procedure occurs in a place which will not be a statement in C,
+the whole do-term is lifted out into a new top-level procedure
+analogously to lambda-lifting.  Any statement-lifted parts of some
+procedure foo are called foo_auxN, where N is a number.
+
+The special C-ish procedure **return** is pushed into a scheme term as
+far as possible to extend the scope of statements in the resulting C
+program.  For example,
+
+     (define foo
+       (lambda (x y)
+           (if x (+ 1 y) (+ 2 y)) ))
+
+is converted to
+
+     (define foo
+        (lambda (x y)
+          (if x (**return** (+ 1 y)) (**return** (+ 2 y))) ))
+
+Immediate tailrecursion (foo calling foo tailrecursively) is recognized
+and converted into an assignment of new values to args and a jump to
+the beginning of the procedure body.
+
+
+File: hobbit.info,  Node: Higher-order Arglists,  Next: Typing and Constants,  Prev: Statement-lifting,  Up: Principles of Compilation
+
+Higher-order Arglists
+=====================
+
+All procedures taking a list argument are converted into ordinary
+non-list taking procedures and they are called with the list-making
+calls inserted.  For example,
+
+     (define foo
+       (lambda (x . y)
+         (cons x (reverse y)) ))
+
+is converted to
+
+     (define foo
+       (lambda (x y)
+         (cons x (reverse y)) ))
+
+and any call to foo will make a list for a variable y.  For example,
+
+     (foo 1 2 3)
+
+is converted to
+
+     (foo 1 (cons 2 (cons 3 '()))).
+
+All higher-order procedure calls where an argument-term contains
+unbound variables will generate a new instance (provided it has not
+been created already) of this higher-order procedure, carrying the
+right amount of free variables inside to right places.
+
+For example, if there is a following definition:
+
+     (define (member-if fn lst)
+        (if (fn (car lst))
+            lst
+            (member-if fn (cdr lst)) ))
+
+and a call
+
+     (member-if (lambda (x) (eq? x y)) lst),
+
+a new instance of member-if is created (if an analogous one has not
+been created before):
+
+     (define (member-if_inst1 tmp fn lst)
+        (if (fn tmp (car lst))
+            lst
+            (member-if_inst1 tmp fn (cdr lst)) ))
+
+and the call is converted to
+
+     (member-if_inst1 y foo lst)
+
+and a top-level define
+
+     (define (foo y x) (eq? x y))
+
+In addition, if the higher-order procedure is to be exported, an
+additional instance is created, which uses apply to call all
+argument-procedures, assuming they are defined via interpreter.  The
+exportable higher-order procedure will have a name FUN_exporthof, where
+FUN is the name of the original procedure.
+
+
+File: hobbit.info,  Node: Typing and Constants,  Prev: Higher-order Arglists,  Up: Principles of Compilation
+
+Typing and Constants
+====================
+
+All C<->Scheme conversions for immediate objects like numbers, booleans
+and characters are introduced.  Internal apply is used for undefined
+procedures.  Some optimizations are performed to decrease the amount of
+C<->Scheme object conversions.
+
+All vector, pair and string constants are replaced by new variables.
+These variables are instantiated to the right values by init_FOO*.
+
+Procedures foo which are to be exported (made accesible to the
+interpreter), and which have an arity different from one of the
+following five templates: x, (), (x), (x y), (x y z), are made
+accessible via an additional procedure foo_wrapper taking a single list
+argument.
+
+C Code Generation
+-----------------
+
+More or less straightforward.
+
+The type conversion between C objects and immediate Scheme objects of
+the type boolean, char and num is performed by macros.  The scheme
+object '() is represented by the macro object EOL.
+
+Intermediate files
+------------------
+
+Experiment yourself by defining:
+
+     (define *build-intermediate-files* #t)
+
+instead of the default:
+
+     (define *build-intermediate-files* #f).
+
+
+File: hobbit.info,  Node: About Hobbit,  Prev: Principles of Compilation,  Up: Top
+
+About Hobbit
+************
+
+* Menu:
+
+* The Aims of Developing Hobbit::
+* Manifest::
+* Author and Contributors::
+* Future Improvements::
+* Release History::
+
+
+File: hobbit.info,  Node: The Aims of Developing Hobbit,  Next: Manifest,  Prev: About Hobbit,  Up: About Hobbit
+
+The Aims of Developing Hobbit
+=============================
+
+  1. Producing maximally fast C code from simple scheme code.
+
+     By "simple" we mean code which does not rely on procedures
+     returning procedures (closures) and nontrivial forms of
+     higher-order procedures.  All the latter are also compiled, but
+     the optimizations specially target simple code fragments.  Hobbit
+     performs global optimization in order to locate such fragments.
+
+  2. Producing C code which would preserve as much original scheme code
+     structure as possible, to enable using the output C code by a
+     human programmer (eg. for introducing special optimizations
+     possible in C).  Also, this will hopefully help the C compiler to
+     find better optimizations.
+
+
+File: hobbit.info,  Node: Manifest,  Next: Author and Contributors,  Prev: The Aims of Developing Hobbit,  Up: About Hobbit
+
+Manifest
+========
+
+`hobbit.scm'   the hobbit compiler.
+`scmhob.scm'   the file defining some additional procedures recognized
+               by hobbit as primitives.  Use it with the interpreter
+               only.
+`scmhob.h'     the common headerfile for hobbit-compiled C files.
+`hobbit.texi'  documentation for hobbit.
+
+
+File: hobbit.info,  Node: Author and Contributors,  Next: Future Improvements,  Prev: Manifest,  Up: About Hobbit
+
+Author and Contributors
+=======================
+
+     Tanel Tammet
+     Department of Computing Science
+     Chalmers University of Technology
+     University of Go"teborg
+     S-41296 Go"teborg Sweden
+
+A. Jaffer (jaffer @ alum.mit.edu), the author of SCM, has been of major
+help with a number of suggestions and hacks, especially concerning the
+interface between compiled code and the SCM interpreter.
+
+Several people have helped with suggestions and detailed bug reports,
+e.g. David J. Fiander (davidf@mks.com), Gordon Oulsnam
+(STCS8004@IRUCCVAX.UCC.IE), Pertti Kelloma"ki (pk@cs.tut.fi), Dominique
+de Waleffe (ddw2@sunbim.be) Terry Moore (tmm@databook.com), Marshall
+Abrams (ab2r@midway.uchicago.edu).  Georgy K. Bronnikov
+(goga@bronnikov.msk.su), Bernard Urban (Bernard.URBAN@meteo.fr),
+Charlie Xiaoli Huang, Tom Lord (lord@cygnus.com),
+NMICHAEL@us.oracle.com, Lee Iverson (leei@ai.sri.com), Burt Leavenworth
+(EDLSOFT@aol.com).
+
+
+File: hobbit.info,  Node: Future Improvements,  Next: Release History,  Prev: Author and Contributors,  Up: About Hobbit
+
+Future Improvements
+===================
+
+  1. Optimisations:
+
+        * the calls to internal apply: we'd like to avoid the excessive
+          consing of always building the list of arguments.
+
+        * speeding up the creation of a vector for assignable
+          closure-variables
+
+        * several peephole optimisations.
+
+  2. Improve Variable creation and naming to avoid C function name
+     clashes.
+
+  3. Report 4 macros.
+
+  4. Better error-checking.
+
+  5. Better liftability analysis.
+
+  6. More tailrecursion recognition.
+
+  7. Better numeric optimizations.
+
+  8. Fast real-only arithmetics: $eqv, $=, $>, $+, $*, etc.
+
+
+File: hobbit.info,  Node: Release History,  Prev: Future Improvements,  Up: About Hobbit
+
+Release History
+===============
+
+     [In February 2002, hobbit5x was integrated into the SCM
+     distribution.  Changes since then are recorded in `scm/ChangeLog'.]
+
+hobbit4d:
+        * the incorrect translation of char>?, char-ci>?, char>=?,
+          char-ci>=?  string>?, string-ci>?, string-ci>=?, string>=?
+          reported by Burt Leavenworth (EDLSOFT@aol.com) was fixed.
+
+        * the name clash bug for new variables new_varN occurring in
+          non-liftable closures (reported by Lee Iverson
+          (leei@ai.sri.com)) was fixed.
+
+        * the major COPYRIGHT change: differently from all the previous
+          versions of Hobbit, hobbit4d is Free Software.
+
+hobbit4c:
+        * a liftability-analysis bug for for-each and map reported by
+          Lee Iverson (leei@ai.sri.com) has been fixed.
+
+        * The output C code does not contain the unnecessary ;-s on
+          separate lines any more.
+
+hobbit4b:
+     The following bugs have been fixed:
+        * Erroneous treatment of [ and ] inside symbols, reported by A.
+          Jaffer (jaffer @ alum.mit.edu).
+
+        * A bug in the liftability analysis, reported by A. Jaffer
+          (jaffer @ alum.mit.edu).
+
+        * A bug occurring in case arguments are evaluated right-to-left,
+          which happens with Hobbit compiled by gcc on Linux.  Reported
+          and patched by George K. Bronnikov (goga@bronnikov.msk.su)
+
+        * A closure-building bug sometimes leading to a serious loss of
+          efficiency (liftability not recognized), reported by
+          NMICHAEL@us.oracle.com.
+
+        * A bug in the liftability analysis (non-liftable lambda-term
+          inside a liftable lambda-term) reported by Lee Iverson
+          (leei@ai.sri.com)
+
+hobbit4a:
+     Several bugs found in version4x are fixed.
+
+hobbit4x (not public):
+        * A major overhaul: Hobbit is now able to compile full scheme,
+          not just the fast liftable-clonable fragment.
+
+          The optimizations done by the earlier versions are preserved.
+
+        * Numerous bugs found in earlier versions have been fixed.
+
+hobbit3d:
+     bugs found in the version 3c are fixed.
+
+hobbit3c:
+        * the form
+
+               (define foo (let ((x1 <t1>) ... (xn <tn>)) (lambda ...)))
+
+          is now supported for all terms <ti> except procedures defined
+          in the compiled files.
+
+        * macros are partially supported by doing a preprocessing pass
+          using the procedures pprint-filter-file and defmacro:expand*
+          defined in slib.
+
+        * the file `scmhob.scm' defining hobbit-recognized nonstandard
+          procedures is created.
+
+        * the documentation is improved (thanks go to Aubrey for
+          suggestions).
+
+hobbit3b:
+        * Aubrey fixed some problems with the version 3.
+
+        * It is now OK to define procedures "by name" on top level.
+
+        * It is now OK to apply "apply", etc to procedures defined in
+          the compiled file.  Compiled procedures may now be passed to
+          procedures not defined but still called in the compiled files.
+
+hobbit3:
+        * Generic arithmetic supported by SCM (exact and inexact reals,
+          bignums) is made available.
+
+        * The #. special syntactic form of SCM is made available.
+
+        * Procedures with chars are compiled open-coded, making them
+          faster.
+
+        * The bug concerning strings containing an embedded \nl char is
+          corrected (thanks to Terry Moore, (tmm@databook.com)).
+
+        * The special declaration compile-stable-vectors for optimizing
+          vector access is introduced.
+
+        * Source code may contain top-level computations, top-level
+          loads are ignored.
+
+        * The bug causing "or" to (sometimes) lose tailrecursiveness is
+          corrected.
+
+        * Hobbit now allows the following very special form:
+
+               (define foo (let ((bar bar)) (lambda ...)))
+
+          Notice `(bar bar)'.  See the section 5 above.  It will
+          produce wrong code if bar is redefined.
+
+          There were several versions of the 2-series, like 2.x, which
+          were not made public.  The changes introduced are present in
+          the version 3.
+
+hobbit2:
+        * The following bitwise procedures in the scheme library file
+          `logical.scm' are compiled directly to C (Scheme library funs
+          in the upper row, C ops below):
+
+               logand logior logxor lognot logsleft logsright
+                  &      |     ^      ~       <<        >>
+
+          Notice that the procedures logsleft, logsright are NOT in the
+          the library file `logical.scm': the universal procedure ash
+          is instead.  Procedures ash, logcount, integer-length,
+          integer-expt, bit-extract in `logical.scm' are not recognized
+          by hobbit.
+
+hobbit1a3 (not public):
+        * the letrec-sorting bug often resulting in not recognizing
+          procedures defined in letrec (or local defines) has been
+          corrected.
+
+        * the primitives string and vector are now compiled correctly.
+
+hobbit1a2 (not public):
+        * any fixed arity procedure (including primitives) may be
+          passed to any higher-order procedure by name.  Variable arity
+          procedures (eg primitives list, +, display and defined funs
+          like `(define (foo x . y) x)') must not be passed to new
+          defined higher-order funs.
+
+        * some optimizations have been introduced for calls to map and
+          for-each.
+
+        * (map list x y) bug has been corrected.
+
+        * Corrected self-compilation name clash between call_cc and
+          call-cc.
+
+hobbit1a1 (not public):
+        * named let is supported.
+
+        * the inlining bug is fixed: all procedures declared to be
+          inlined are fully inlined, except when the flag
+          *full-inlining-flag* is defined as #f.
+
+        * the letrec (or in-procedure define) bug where local procedure
+          names were not recognized, is fixed.
+
+        * documentation says explicitly that definitions like
+
+               (define foo (let ((x 0)) (lambda (y) ...)))
+
+          are assumed to be closure-returning procedures and are
+          prohibited.
+
+        * documentation allows more liberty with passing procedures to
+          higher-order funs by dropping the general requirement that
+          only unnamed lambda-terms may be passed.  Still, primitives
+          and list-taking procedures may not be passed by name.
+
+        * documentation prohibits passing lambda-terms with free
+          variables to recursive calls of higher-order procedures in
+          the definition of a higher-order procedure.
+
+hobbit1:
+     the first release
+
+
+
+Tag Table:
+Node: Top199
+Node: Introduction1217
+Node: Compiling with Hobbit2533
+Node: Compiling And Linking2786
+Node: Error Detection7267
+Node: Hobbit Options8565
+Node: CC Optimizations15286
+Node: The Language Compiled16234
+Node: Macros16889
+Node: SCM Primitive Procedures17485
+Node: SLIB Logical Procedures18336
+Node: Fast Integer Calculations19616
+Node: Force and Delay20742
+Node: Suggestions for writing fast code21319
+Node: Performance of Compiled Code31510
+Node: Gain in Speed31766
+Node: Benchmarks33343
+Node: Benchmark Sources36435
+Node: Destruct36773
+Node: Recfib38348
+Node: div-iter and div-rec38591
+Node: Hanoi39665
+Node: Tak40234
+Node: Ctak40577
+Node: Takl41560
+Node: Cpstak42219
+Node: Pi42986
+Node: Principles of Compilation44103
+Node: Macro-Expansion and Analysis44525
+Node: Building Closures48308
+Node: Lambda-lifting51191
+Node: Statement-lifting53939
+Node: Higher-order Arglists55039
+Node: Typing and Constants56837
+Node: About Hobbit58093
+Node: The Aims of Developing Hobbit58335
+Node: Manifest59218
+Node: Author and Contributors59669
+Node: Future Improvements60719
+Node: Release History61476
+
+End Tag Table
diff --git a/hobbit.scm b/hobbit.scm
new file mode 100644
index 0000000..80d9d31
--- /dev/null
+++ b/hobbit.scm
@@ -0,0 +1,6981 @@
+;====================================================================

+;

+;	    HOBBIT: an optimizing scheme -> C compiler for SCM

+;

+;                   scm5d6

+;                   2002-04-11

+;

+;                   Copyright (C) 1992-1997: Tanel Tammet

+;                   Copyright (C) 1998-2002: Free Software Foundation

+;

+;	    tammet@staff.ttu.ee, tammet@cs.chalmers.se

+;

+;		    Tanel Tammet

+;                   Department of Computer Science

+;                   Tallinn University of Technology

+;                   Raja 15

+;                   12618, Tallinn

+;                   Estonia

+;

+;		    Department of Computing Science

+;		    Chalmers University of Technology

+;		    University of Go"teborg

+;		    S-41296 Go"teborg

+;		    Sweden

+;

+;

+;		Documentation is in the file hobbit.texi

+;

+;                 NB! the terms for usage, copying

+;   and redistribution of hobbit are given in the file COPYING

+;

+;

+; This program is free software; you can redistribute it and/or modify

+; it under the terms of the GNU General Public License as published by

+; the Free Software Foundation; either version 1, or (at your option)

+; any later version.

+;

+; This program is distributed in the hope that it will be useful,

+; but WITHOUT ANY WARRANTY; without even the implied warranty of

+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

+; GNU General Public License for more details.

+;

+; You should have received a copy of the GNU General Public License

+; along with this program; if not, write to the Free Software

+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.

+;====================================================================

+;

+; Last part of changelog:

+;

+; april 2-11, 2002, Tanel Tammet:

+;   -  "system" and "verbose"  compilation corrected

+;      (system was previously not compiled, verbose is compiled to prolixity)

+;   -  "require" moved from top level to hobbit procedure (necessary

+;       for self-compilation)

+;   -  "copy-tree" and "acons" compilation introduced

+; pre-april, 2002, Aubrey Jaffer:

+;   -  numerous changes necessary for co-operation with SCM5d5

+;

+;=================================================================

+;

+;		   default compiler options

+;		      (may be changed)

+;

+;=================================================================

+

+

+;;; The following variable controls whether hobbit will do any

+;;; macroexpansion. In that case (require 'defmacroexpand) must

+;;; be able to load the macroexpander from the scheme library.

+

+(define *expand-macros-flag* #t)

+

+;;; The following variable controls whether functions declared

+;;; to be inlined are inlined in full or only once. If the set of

+;;; nested inlinable function defs contains a circularity, the

+;;; setting #t will cause Hobbit to go into an infinite loop.

+

+(define *full-inlining-flag* #t)

+

+;;; The following variable controls whether any intermediate files

+;;; will be built. In that case (require 'pretty-print) and

+;;; (require 'pprint-load) must be able to load the prettyprinter

+;;; from the scheme library.

+

+(define *build-intermediate-files* #f)

+

+;;; The following variable controls whether any information about

+;;; compilation (except warnings and error messages) are printed.

+

+(define *infomessages-flag* #t)

+

+;;; The following variables control whether all map-s and for-each-s

+;;; are converted into inline-do-loops, or map-s and for-each-s

+;;; taking only one list are compiled as any other higher-order call

+;;; to functions map1 and for-each1 (inserted by the compiler in case

+;;; of need).

+

+(define *always-map->do-flag* #f)

+(define *always-for-each->do-flag* #f)

+

+

+;================================================================

+;

+;		 C-specific and system-specific options

+;                       (change if needed)

+;

+;===============================================================

+

+;;; If your C compiler does not assume that integers without a cast

+;;; are long ints, you may need to set the following flag to #t.

+;;; In that case all integers in the output C text, which should

+;;; be long ints, will have a trailing L cast.

+

+(define *long-cast-flag* #f)

+

+;;; If your C compiler may compile the C operator <test> ? <r1> : <r2>

+;;; to the code which may evaluate BOTH <r1> and <r2> in one

+;;; evaluation of the whole operator, you MUST define *lift-ifs-flag*

+;;; as #t.

+

+(define *lift-ifs-flag* #f)

+

+;;; If you C compiler may compile the C operator <a1> || <a2>

+;;; to the code which may evaluate <a2> even if <a1> evaluates to 1,

+;;; or, analogically, <a1> && <a2> may evaluate <a2> even if

+;;; <a1> evaluates to 0, you MUST define *lift-and-or-flag* as #t.

+

+(define *lift-and-or-flag* #f)

+

+;;; The following flag may be false only if the output C program

+;;; is supposed to run only on systems where the following holds:

+;;; ((-1%2 == -1) && (-1%-2 == -1) && (1%2 == 1) && (1%-2 == 1).

+;;; Otherwise the following flag must be #t.

+

+(define *badivsgns-flag* #f)

+

+;;; *input-file-modifier* and *output-file-modifier*

+;;; are strings which are given to the C file-opener to

+;;; indicate the mode of the file to be opened.

+;;; Select the MSDOS or ATARI version if appropriate, or define

+;;; your own modifier-strings.

+

+(define *input-file-modifier* "r")     ;;; for UNIX & others

+(define *output-file-modifier* "w")    ;;; for UNIX & others

+

+;;; (define *input-file-modifier* "rb")    ;;; for MSDOS & ATARI

+;;; (define *output-file-modifier* "wb")   ;;; for MSDOS & ATARI

+

+;;; The following variable controls the maximal length of auxiliary

+;;; functions created by the compiler (longer functions are split

+;;; into separate chunks).

+

+(define *max-auxfun-size* 50)

+

+;====================================================================

+;

+;  Scheme-implementation-specific definitions. Change if needed.

+;

+;====================================================================

+

+(define (report-error . lst)

+  (display #\newline)

+  (display "COMPILATION ERROR: ")

+  (display #\newline)

+  (for-each display lst)

+  (display #\newline)

+  (abort))

+

+(define compile-allnumbers #t)

+

+;=================================================================

+;

+;			renamable constants

+;	       (you might need to change some of these to

+;			avoid name clashes)

+;

+;=================================================================

+

+

+;;;  If your scheme file contains symbols which start

+;;;  with a number, then *c-num-symb-prefix* is prefixed to

+;;;  such symbols in the C source.

+

+(define *c-num-symb-prefix* "nonum_prefix_")

+

+;;; NB! If your scheme file contains variables which are also

+;;;     C keywords or C functions defined in scm,

+;;;     the string *c-keyword-postfix* is added to such variable names.

+;;;     The list of prohibited variables is *c-keywords*. Add new

+;;;     variables there, if needed.

+

+(define *c-keyword-postfix* "_nonkeyword")

+

+(define *c-keywords*

+  '(auto double int struct break else long switch

+    case enum register typedef char extern return union

+    const float short unsigned continue for signed void

+    default goto sizeof volatile do if static while

+

+;;; Some things are commented out to make hobbit compile itself correctly.

+

+ sizet void cell subr iproc smobfuns dblproc flo dbl isymnames s-and

+ s-begin s-case s-cond s-do s-if s-lambda s-let s-letstar s-letrec s-or

+ s-quote s-set i-dot i-quote i-quasiquote i-unquote i-uq-splicing

+ tcs-cons-imcar tcs-cons-nimcar tcs-cons-gloc tcs-closures tcs-subrs

+ tc7-asubr tcs-symbols tc7-ssymbol tcs-bignums tc16-bigpos tc3-cons

+ tc3-cons-gloc tc3-closure tc7-ssymbol tc7-msymbol tc7-string

+ tc7-vector tc7-bvect tc7-ivect tc7-uvect tc7-fvect tc7-dvect tc7-cvect

+ tc7-contin tc7-cclo tc7-asubr

+;;; tc7-subr-0 tc7-subr-1

+ tc7-cxr

+;;; tc7-subr-3 tc7-subr-2

+ tc7-subr-2x tc7-subr-1o tc7-subr-2o tc7-lsubr-2

+;;; tc7-lsubr

+ tc7-smob tc-free-cell tc16-flo tc-flo tc-dblr tc-dblc

+ tc16-bigpos tc16-bigneg tc16-port tc-inport tc-outport tc-ioport

+ tc-inpipe tc-outpipe smobfuns numsmob sys-protects cur-inp cur-outp

+ listofnull undefineds nullvect nullstr symhash progargs transcript

+ def-inp def-outp rootcont sys-protects upcase downcase symhash-dim

+ heap-size stack-start-ptr heap-org freelist gc-cells-collected

+ gc-malloc-collected gc-ports-collected cells-allocated linum

+ errjmp-ok ints-disabled sig-deferred alrm-deferred han-sig han-alrm

+ must-malloc ilength s-read s-write s-newline s-make-string

+ s-make-vector s-list s-string s-vector repl-driver newsmob lthrow repl

+ gc-end gc-start growth-mon iprin1 intprint iprlist lputc lputs

+ lfwrite time-in-msec my-time init-tables init-storage init-subrs

+ init-features init-iprocs init- init-scl init-io init-repl init-time

+ init-signals ignore-signals unignore-signals init-eval init-sc2

+ free-storage init-unif uvprin1 markcdr free0 warn wta everr sysintern

+;;; intern

+ sym2vcell makstr

+;;; make-subr

+;;; makfromstr

+ closure makprom force

+ makarb tryarb relarb ceval prolixity gc gc-for-newcell tryload cons2

+;;; acons

+ resizuve cons2r lnot booleanp eq equal consp cons nullp

+ setcar setcdr listp list length append reverse list-ref memq memv

+ member assq assv assoc symbolp symbol2string string2symbol numberp exactp

+ inexactp eqp lessp zerop positivep negativep oddp evenp lmax lmin sum

+ product difference lquotient absval remainder lremainder modulo lgcd llcm

+ number2string

+;;; string2number

+ makdbl istr2flo mkbig long2big dbl2big

+ iint2str iflo2str floprint bigprint big2dbl charp char-lessp chci-eq

+ chci-lessp char-alphap char-nump char-whitep char-upperp char-lowerp

+ char2int int2char char-upcase char-downcase stringp make-string

+ string st-length st-ref st-set st-equal stci-equal st-lessp

+ stci-lessp substring st-append vectorp make-vector

+ vector

+ vector-length vector-ref vector-set for-each procedurep apply map

+ call-cc copytree

+;;; eval

+ throwval quit input-portp output-portp

+ cur-input-port cur-output-port open-file open-pipe close-port

+ close-pipe lread read-char peek-char eof-objectp lwrite display

+ newline write-char file-position file-set-position lgetenv prog-args

+ makacro makmacro makmmacro

+ remove ash round array-ref array_ref

+ sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt

+ log abs exp

+ ;; verbose copy-tree @copy-tree

+ last-pair subml submr subfl		;from sc2.c

+))

+

+

+;;; NB! Your scheme file must not contain symbols which end with

+;;;     the third elements of the following defines appended

+;;;     with an integer. The same holds for the case where "-" is written

+;;;     instead of "_". In case your scheme file contains any offending

+;;;     symbols, replace them either in your file or replace the offending

+;;;     strings in the following defines.

+;;;

+;;;     E.g. it is not allowed to have symbols like: my__12, spec-tmp-var3,

+;;;     foo-inst1, foo_inst5, bar-aux2.

+;;;

+;;;     E.g. it is allowed to have symbols like: my__x, spec_tmp_var,

+;;;     foo-inst1x, foo_inst_5, bar-aux-spec.

+

+(define *local-var-infix* "__")

+(define *new-var-name* "new_var")

+(define *tmp-var-name* "tmp_var")

+(define *new-parameter-prefix* "npar__")

+(define *new-fun-infix* "_aux")

+(define *new-letfun-infix* "_fn")

+(define *new-instfun-infix* "_inst")

+(define *new-constant-prefix* "const_")

+(define *closure-name-suffix* "_cl")

+(define *closure-vector-name* "clargsv_")

+

+;;; The following are names for the additional scheme functions

+;;; nonkeyword-make-promise and nonkeyword-force.

+;;; If your scheme file contains a function

+;;; with these names already, you must change the following names.

+

+(define *make-promise-function* 'nonkeyword_make-promise)

+(define *force-function* 'nonkeyword_force)

+

+;;; The following two will be names for the additional scheme functions

+;;; map1 and for-each1. If your scheme file contains any functions with

+;;; such names already, you must change the following names.

+

+(define *map1-function* 'map1)

+(define *for-each1-function* 'for-each1)

+

+;;; The following name is not allowed to occur in your scheme file,

+;;; neither is <name>_<nr> allowed.

+

+(define *new-closure-var* "newclosure")

+

+;;; The following is appended to symbols (not variables!) in your scheme

+;;; file. Thus your scheme file should not contain variables or symbols

+;;; ending with the value of *symbol-name-postfix*. If needed, change

+;;; *symbol-name-postfix* from "_symb" to some other string.

+

+(define *symbol-name-postfix* "_symb")

+

+;;; The following is appended to higher-order function names in your scheme

+;;; file which should be accessible from the interpreter. Thus your scheme

+;;; file should not contain variables or symbols

+;;; ending with the value of *export-hof-postfix*. If needed, change

+;;; *export-hof-postfix* from "_exporthof" to some other string.

+

+(define *export-hof-postfix* "_exporthof")

+

+;;; The following is needed for exportable functions which do not

+;;; have a type available in scm and need a special wrapper-function

+;;; to pass variables supplied by the interpreter. The wrapper function

+;;; name for some function foo is foo_wrapper, unless you change

+;;; the following define.

+

+(define *wrapper-postfix* "_wrapper")

+

+;;; The following is appended to those function names in your scheme

+;;; which are passed in the file to functions defined out of file

+;;; or to append: in other words, passed to interpreter

+

+(define *interpreter-suffix* "_interpreter")

+

+;;; The following is appended to names of stable vectors, to

+;;; denote the precalculated VELTS(x) part of a stable vector x.

+

+(define *st-vector-postfix* "_velts0")

+

+;;; The following is appended to names of closure procedures, giving

+;;; the C-only static SCM variable name

+

+(define *closure-proc-suffix* "_clproc0")

+

+;;; The following is a string which is prepended to the name of your

+;;; scheme file (without .scm) to form a name of a function generated

+;;; to initialize non-function defined variables in your scheme file.

+

+(define *init-globals-prefix* "init_globals_")

+

+;;; The following is a string which is prepended to the name of your

+;;; scheme file (without .scm) to form a name of a function generated

+;;; to perform all top-level computations in your scheme file.

+

+(define *top-actions-prefix* "top_actions_")

+

+;;; The following is a string which is prepended to the name of your

+;;; scheme file (without .scm) to form a name of a main initialization

+;;; function for your file.

+

+(define *init-fun-prefix* "init_")

+

+;;; The following is a string which is prepended to the name of your

+;;; scheme file (without .scm) to form a C variable which is generated

+;;; as a new global to gc-protect the constant nonimmediate objects

+;;;  in your file.

+

+(define *protect-variable* "protect_constants_")

+

+;;; The following is a name of a variable which may be defined to

+;;; the list of inlinable functions in your scheme file.

+

+(define *inline-declare* 'compile-inline)

+

+;;; The following is a name of a variable which may be defined to

+;;; the list of inlinable variables in your scheme file.

+

+(define *inline-vars-declare* 'compile-inline-vars)

+

+;;; The following is a name of a variable which has to be defined to

+;;; make hobbit compile numeric procedures for all numbers as default,

+;;; not just integers:

+

+(define *allnumbers-declare* 'compile-allnumbers)

+

+;;; The following is a name of a variable which has to be defined to

+;;; make hobbit assume all procedures may be redefined.

+

+(define *all-funs-modified-declare* 'compile-all-proc-redefined)

+

+;;; The following is a name of a variable which has to be defined to

+;;; make hobbit assume all procedures may be redefined.

+

+(define *new-funs-modified-declare* 'compile-new-proc-redefined)

+

+;;; The following is a name of a variable which may be defined to

+;;; the list of exportable functions in your scheme file.

+

+(define *export-declare* 'compile-export)

+

+;;; The following is a name of a variable which may be defined to

+;;; the list of stable vector names (never-assigned except the first

+;;; initialization, not even by let or as local variables) in your

+;;;  scheme file.

+

+(define *stable-vectors-declare* 'compile-stable-vectors)

+

+;;; The following is a name of a variable which may be defined to

+;;; the list of uninterned fast global vars (never holding nonimmediate values,

+;;; ie not char, bool or short int). These vars are NOT accessible

+;;; by the interpreter! They are used directly as C vars, without the GLOBAL

+;;; (ie * op) prefix.

+

+(define *fast-vars-declare* 'compile-uninterned-variables)

+

+;;; The following two are default names for the single argument

+;;; of the closure function and the variable which is assigned its

+;;; first element.

+

+(define *closurefun-arg* 'closurearg_0)

+(define *closurefun-arg-car* 'closurearg_car_0)

+

+;;; NB! The following determine the replacements for symbols

+;;;     allowed in scheme variables but not in C variables.

+;;;     Be careful with your scheme variables to avoid

+;;;     name clashes! E.g. if you have scheme variables

+;;;     bar--plus_, bar-+ and bar_+, they will all be converted to

+;;;     the same C variable bar__plus_

+;;;     In case of need feel free to change the replacement table.

+;;;     You may also wish to change the scheme function

+;;;     display-c-var, which performs the conversion.

+;;;

+;;;     *global-postfix* determines the string to be appended to

+;;;     variable names surrounded by *-s. The surrounding *-s

+;;;     are dropped. E.g. *special-flag* will be converted to

+;;;     special_flag_global

+;;;     *char-replacements* determine the replacement strings

+;;;     for characters not allowed in C variables. E.g. foo!?

+;;;     will be converted to foo_excl__pred_

+

+(define *global-postfix* "_global")

+

+(define *char-replacements*

+  '((#\+ "_plus_")

+    (#\- "_")

+    (#\@ "_at_")

+    (#\. "_dot_")

+    (#\* "_star_")

+    (#\/ "_slash_")

+    (#\< "_less_")

+    (#\= "_equal_")

+    (#\> "_grtr_")

+    (#\! "_excl_")

+    (#\? "_pred_")

+    (#\: "_colon_")

+    (#\$ "_dollar_")

+    (#\% "_percent_")

+    (#\_ "_")

+    (#\& "_and_")

+    (#\~ "_tilde_")

+    (#\^ "_exp_")

+    (#\[ "_obrckt_")

+    (#\] "_cbrckt_")

+    (#\| "_vbar_")))

+

+;;; *c-indent* is the one-level indentation for C statements.

+;;; There is no indentation for C expressions.

+

+(define *c-indent* "  ")

+

+;;; *c-infix-surround* is put before and after each infix C operator.

+;;; The sensible alternative to default "" is " " or #\space.

+

+(define *c-infix-surround* "")

+

+;;; The following are some obvious C constants. *c-null* is the

+;;; C object corresponding to scheme '().

+

+(define *c-true* 1)

+(define *c-false* 0)

+(define *c-null* "EOL")

+(define *scm-type* "SCM")

+(define *unspecified* '**unspecified**) ; you may change it

+

+;;; NB! Your scheme file must not contain any third symbols

+;;;     of the following defines. If it does, replace the

+;;;     offending symbol either in your file or in the following

+;;;     defines (the compiler must contain the replacement anywhere

+;;;     else).

+

+(define *function* '**function**)

+(define *higher-order-call* '**higher-order-call**)

+(define *higher-order-flag* #f)

+(define *dummy* '**dummy**)

+(define *not?* '**not?**)

+(define *and?* '**and**)

+(define *or?* '**or**)

+(define *open-file-function* '**open-file-function**)

+(define *set-current-input-port-function*

+  '**set-current-input-port-function**)

+(define *set-current-output-port-function*

+  '**set-current-output-port-function**)

+(define *num-s->c* '**num-s->c**)

+(define *num-c->s* '**num-c->s**)

+(define *bool-s->c* '**bool-s->c**)

+(define *bool-c->s* '**bool-c->s**)

+(define *char-c->s* '**char-c->s**)

+(define *float-c->s* '**float-c->s**)

+(define *tailrec* '**tailrec**)

+(define *c-fetch* '**c-fetch**)

+(define *c-adr* '**c-adr**)

+(define *op-if* '**op-if**)

+(define *op-begin* '**op-begin**)

+(define *op-let* '**op-let**)

+(define *do-not* '**do-not**)

+(define *return* '**return**) ; NB! do not change this!!!

+(define *goto-tailrec* '**goto-tailrec**)

+(define *mark-tailrec* '**mark-tailrec**)

+(define *define-constant* '**define-constant**)

+(define *actual-c-string* '**actual-c-string**)

+(define *actual-c-expr* '**actual-c-expr**)

+(define *actual-c-int* '**actual-c-int**)

+(define *actual-c-eval* '**actual-c-eval**)

+(define *special-pseudoquote* '**special-pseudoquote**)

+(define *global-access* '**global-access**)

+(define *sysapply* '**sysapply**)

+(define *listofnull* '**listofnull**)

+(define *velts-function* '**velts-function**)

+(define *st-vector-set* '**st-vector-set**)

+(define *st-vector-ref* '**st-vector-ref**)

+(define *make-cclo* '**make-cclo**)

+

+

+(define *special-scm->c-functions*

+ (list

+*function*

+*higher-order-call*

+*dummy*

+*not?*

+*and?*

+*or?*

+*open-file-function*

+*set-current-input-port-function*

+*set-current-output-port-function*

+*num-s->c*

+*num-c->s*

+*bool-s->c*

+*bool-c->s*

+*char-c->s*

+*float-c->s*

+*tailrec*

+*c-fetch*

+*c-adr*

+*op-if*

+*op-begin*

+*op-let*

+*do-not*

+*return*

+*goto-tailrec*

+*mark-tailrec*

+*define-constant*

+*actual-c-string*

+*actual-c-int*

+*actual-c-eval*

+*special-pseudoquote*

+*global-access*

+*listofnull*

+*velts-function*

+*st-vector-set*

+*st-vector-ref*

+*sysapply*

+*make-cclo*

+*unspecified*))

+

+

+;;; *intern-function* must be a C function taking a C string

+;;; and its length (C int) which builds a new scheme symbol

+;;; and returns it.

+;;; *makfromstr-function* must be a C function taking a C string

+;;; and its length (C int) which builds a new scheme string

+;;; and returns it.

+;;; *string->number-function* must be a C function taking a scheme string

+;;; and a radix (scheme int) which builds a new scheme number

+;;; and returns it.

+;;; Instead of using such special functions it is possible to

+;;; change the compiler functions make-symbol-constant and

+;;; make-string-constant instead.

+

+(define *intern-function* 'intern)

+(define *intern-symbol-function* 'intern)

+(define *makfromstr-function* 'makfromstr)

+(define *string->number-function* 'string2number)

+(define *c-eval-fun* 'eval)

+

+(define *internal-c-functions*

+  (list *intern-function* *makfromstr-function*

+	 *intern-symbol-function* *string->number-function* *c-eval-fun*))

+

+(define *prohibited-funs* '())

+

+;;; *type-converters* is a list of scheme<->C representation

+;;; converters.

+

+(define *type-converters*

+  (list *num-s->c* *num-c->s* *bool-s->c* *bool-c->s*

+	*char-c->s* *float-c->s*))

+

+;;; The following four defines specify functions which will either

+;;;	take or return (or both) C numbers or booleans. They

+;;;     are actually set in set-primitive-tables.

+;;;

+;;; *num-arg-c-funs* is a set of scheme functions which will be

+;;;	converted to analogous C functions (provided

+;;;	*reckless-arithmetic* is #t) and which take C numbers

+;;;	as arguments.

+;;; *num-res-c-funs* is a set of scheme functions which will

+;;;	converted to analogous C functions (provided

+;;;	*reckless-arithmetic* is #t) and which give C numbers

+;;;	as results.

+;;; *bool-arg-c-funs* is a set of scheme functions which will always be

+;;;	converted to analogous C functions

+;;;	and which take C booleans (int 0 or non-0) as arguments.

+;;; *bool-res-c-funs* is a set of scheme functions which will be

+;;;	converted to analogous C functions (some only if

+;;;	*reckless-arithmetic* is #t) and which give C booleans

+;;;	as results.

+

+(define *num-arg-c-funs* '())

+(define *always-num-arg-c-funs* '())

+(define *num-res-c-funs* '())

+(define *bool-arg-c-funs* '())

+(define *always-bool-res-c-funs* '())

+(define *bool-res-c-funs* '())

+

+;;; cxr-functions is a set of allowed cxr functions. You may

+;;;  extend it if you wish.

+

+(define *cxr-funs*

+  '(car cdr

+    caar cadr cdar cddr

+    caaar caadr cadar caddr cdaar cdadr cddar cdddr

+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr

+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))

+

+;=================================================================

+;

+;		      global variable defs

+;

+;=================================================================

+

+;;; the following variable determines whether floats or ints are used

+

+(define *floats-flag* #f)    ; must be #f in this version

+

+;;; The following variables control error-checking performed by

+;;; the resulting C program and numerical operations.

+

+(define *reckless-arithmetic-flag* #t) ; MUST be #t in this version

+(define *reckless-access-flag* #t)     ; MUST be #t in this version

+

+;;; The following variable controls optimizations of integer

+;;; arithmetic for scheme<->C type conversions.

+

+(define *optimize-arithmetic* #f)      ; MUST be #f in this version

+

+(define *splitted-init-function-names* '())

+(define *splitted-topaction-function-names* '())

+(define *map1-needed-flag* #f)

+(define *for-each1-needed-flag* #f)

+(define *inline-funs* '())

+(define *inline-vars* '())

+(define *top-actions-list* '())

+(define *inline-funs-data* '())

+(define *inline-vars-data* '())

+(define *c-port* '())

+(define *char-replacements-lists* '())

+(define *tmp-var-max* 500)

+(define *initial-defs* '())

+(define *passed-defs* '())

+(define *output-defs* '())

+(define *new-funs-list* '())

+(define *fun-arities-alist* '())

+(define *to-do-fun-list* '())

+(define *via-interpreter-defined* '())

+(define *non-directcomp-list* '())

+(define *current-fun-name* 'foo)

+(define *current-formal-args* '())

+(define *current-formal-argslist* '())

+(define *tailrec-flag* #f)

+(define *tmp-vars* '())

+(define *new-fun-nr* 0)

+(define *new-fun-names* '())

+(define *higher-ordr-flag* #f)

+(define *higher-order-args* '())

+(define *higher-order-funs* '())

+(define *higher-order-templates* '())

+(define *new-parameter-nr* '0)

+(define *make-new-ho-data* '())

+(define *dot-arg-funs* '())

+(define *dot-arg-templates* '())

+(define *new-instnr* '0)

+(define *new-primitive-instnr* '0)

+(define *local-vars* '())

+(define *new-constant-list* '())

+(define *symbol-constant-table* '())

+(define *interpreter-funname-table* '())

+(define *new-constant-num* 0)

+(define *passed-ho-dot-instfuns* '())

+(define *passed-closure-funs* '())

+(define *free-vars-list* '())

+(define *global-vars-list* '())

+(define *var-make-list* '())

+(define *symbol-list* '())

+(define *unknown-functions* '())

+(define *unknown-vars* '())

+(define *local-parameters* '())

+(define *top-level-funs* '())

+(define *export-functions* '())

+(define *export-table* '())

+(define *wrapper-table* '())

+(define *stable-vector-names* '())

+(define *fast-vars-list* '())

+(define *closure-var-vectornames* '())

+(define *lifted-closures-to-do* '())

+(define *lifted-trivial-closure-names* '())

+(define *lifted-closure-names* '())

+(define *liftable-hof-names* '())

+(define *non-liftable-hof-names* '())

+(define *special-c-vars* '())

+(define *closure-name-nr* 0)

+(define *closure-vector-name-nr* 0)

+(define *liftable-hof-database* '())

+(define *letrec-closure-nr* 0)

+(define *letrec-closures* '())

+(define *letrec-closure-init* '())

+(define *not-all-liftable-names* '())

+(define *all-funs-modified-flag* #f)

+(define *new-funs-modified-flag* #f)

+(define *primitives* '())

+(define *symbol-and-fun-list* '())

+(define *hobbit-declaration-vars* '())

+

+;;; the definition of force is used in case 'delay' is

+;;; found inside the program

+

+(define *force-definition*

+  (list

+   'define

+   *force-function*

+   '(lambda (object) (object))))

+

+

+;;; the definition of make-promise is used in case 'delay' is

+;;; found inside the program

+

+(define *make-promise-definition*

+  (list

+   'define

+   *make-promise-function*

+   '(lambda (proc)

+      (let ((result-ready? #f)

+	    (result #f))

+	(lambda ()

+	  (if result-ready?

+	      result

+	      (let ((x (proc)))

+		(if result-ready?

+		    result

+		    (begin (set! result-ready? #t)

+			   (set! result x)

+			   result)))))))))

+

+

+

+;;; a word of warning: the following two defs must not contain any

+;;; of the following: (cond, case, not, or, and, let, letrec, map, for-each)

+;;; and must not contain lambda-terms or clashing variables in let*.

+;;; There might be other analogous restrictions as well!

+

+(define *map1-definition*

+  (list 'define

+	*map1-function*

+	`(lambda (fn lst)

+	   (let* ((res '()) (res-end res))

+	     (do ()

+		 ((,*not?* (pair? lst)) res)

+		 (if (null? res)

+		     (begin (set! res (cons (fn (car lst)) '()))

+			    (set! res-end res))

+		     (begin (set-cdr! res-end (cons (fn (car lst)) '()))

+			    (set! res-end (cdr res-end))))

+		 (set! lst (cdr lst)))))))

+

+

+(define *for-each1-definition*

+  (list 'define

+	*for-each1-function*

+	`(lambda (fn lst)

+	   (do ()

+	       ((,*not?* (pair? lst)) ,*unspecified*)

+	       (fn (car lst))

+	       (set! lst (cdr lst))))))

+

+;=================================================================

+;

+;			     top level

+;

+;=================================================================

+

+

+(define (Hobbit:compile file . files)

+  (hobbit (cons file files)))

+

+

+(define (hobbit file . files)

+  (let* ((tmpname "hobbit.tmp"))

+    (if *build-intermediate-files*

+        (begin (require 'pretty-print)))

+    (if *expand-macros-flag*

+        (begin (require 'defmacroexpand)

+	       (require 'pprint-file)))

+    (if (not (memq 'hobbit *features*))

+	(set! *features* (cons 'hobbit *features*)))

+    (if (or (member '"scmhob.scm" (cons file files))

+	    (member '"scmhob" (cons file files)))

+	(report-error "The file scmhob.scm is not allowed to be compiled!"))

+    (init-global)

+    ;; check for defmacros

+    (if *expand-macros-flag*

+        (if (not (find-if (lambda (x) (file-contains-defmacro? x))

+			  (cons file files)))

+            (set! *expand-macros-flag* #f)))

+    (set! *initial-defs* '())

+    (if *expand-macros-flag* (for-each defmacro:load (cons file files)))

+    (for-each (lambda (x)

+		(if *infomessages-flag*

+                    (begin (newline)

+		           (display "Starting to read ") (display x)))

+		(read-compiled-file x tmpname))

+	      (cons file files))

+    (if *infomessages-flag* (newline))

+    (compile-defs file (reverse *initial-defs*))))

+

+(define (file-contains-defmacro? str)

+  (let ((foundflag #f)

+        (expr '())

+        (port (if (file-exists? str)

+	          (open-input-file str)

+	          (if (file-exists? (string-append str ".scm"))

+		      (open-input-file (string-append str ".scm"))

+		      (report-error "Could not find file " str)))))

+    (if port

+	(do ()

+	    ((or foundflag (eof-object? expr)) foundflag)

+	  (set! foundflag (expr-contains-defmacro? expr))

+	  (set! expr (read port)))

+	#f)))

+

+(define (expr-contains-defmacro? expr)

+  (cond ((not (pair? expr)) #f)

+        ((or (eq? 'quote (car expr)) (eq? 'quasiquote (car expr))) #f)

+        ((eq? 'defmacro (car expr)) #t)

+        (else (pair-find-if (lambda (x) (expr-contains-defmacro? x)) expr))))

+

+

+(define (read-compiled-file file tmpname)

+  (let* ((iport (if (file-exists? file)

+		    (open-input-file file)

+		    (if (file-exists? (string-append file ".scm"))

+			(open-input-file (string-append file ".scm"))

+			(report-error "Could not find file " file))))

+	 (oport (if *expand-macros-flag* (open-output-file tmpname) '()))

+	 (def #t))

+    (if *infomessages-flag* (newline))

+    (if *expand-macros-flag*

+	(begin

+	  (if *infomessages-flag*

+	      (begin

+		(display "Starting macroexpansion building the ")

+		(display "temporary file ")

+		(display tmpname) (display #\.) (newline)))

+	  (pprint-filter-file iport defmacro:expand* oport)

+	  (close-output-port oport)

+	  (set! iport (open-input-file tmpname))))

+    (do ()

+	((eof-object? def)

+	 (close-input-port iport))

+      (set! def (read iport))

+      (cond ((eof-object? def))

+	    ((and (pair? def)

+		  (or (eq? 'load (car def))

+		      (eq? 'require (car def))))

+	     (report-warning "ignoring a load on top level: " def))

+	    (else

+	     (set! *initial-defs* (cons def *initial-defs*)))))))

+

+(define (compile-defs file deflst)

+  (let ()

+    (set! file (descmify file))

+    ;; - - - - adding primitives delay and force, if neccessary - - - - -

+    (if (find-if (lambda (x) (in-fun-position? 'delay x)) deflst)

+	(set! deflst

+	      (append deflst

+		      (append

+		       (list *force-definition*)

+		       (list *make-promise-definition*)))))

+    ;; - - - - - initial checks and flag-setting, sorting out the toplevel

+    ;;  builds *top-level-names*, *modified-primitives* and

+    ;;  *modified-top-level-names*:

+    (make-top-level-namelist! deflst)

+    ;; sorts out the toplevel:

+    (sort-out-toplevel! deflst file)

+    (if (not *floats-flag*)

+        (compute-floats-flag! deflst #t))

+    (if *infomessages-flag*

+        (if *floats-flag*

+	    (begin

+              (display "Generic (slow) arithmetic assumed: ")

+              (display *floats-flag*)

+              (display " found.")

+	      (newline))

+	    (begin

+	      (display "Bounded integer (fast) arithmetic assumed.")

+	      (newline))))

+    (set-primitive-tables)

+    (set! *passed-defs* '())

+    ;; - - - - - vars-simplification pass - -

+    (set! *to-do-fun-list*

+	  (map vars-simplify-wholedef *to-do-fun-list*))

+    ;; - - - - - finding liftable hof-s - - -

+    (set! *liftable-hof-names* '())

+    (set! *non-liftable-hof-names* '())

+    (for-each (lambda (x)

+		(if (and (pair? (caddr x))

+			 (eq? 'lambda (caaddr x))

+			 (liftable-hof? (caddr x) (cadr x)))

+		    (set! *liftable-hof-names*

+			  (cons (cadr x) *liftable-hof-names*))))

+	      *to-do-fun-list*)

+    (for-each lift-analyse-def! *to-do-fun-list*)

+    (if *infomessages-flag*

+        (begin (newline) (display "** Pass 1 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".anl"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *to-do-fun-list*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "analyzed & marked definitions file ")

+	  (display (string-append file '".anl"))

+	  (display " is built.")))

+    ;; initial analysis passes completed

+    ;; - - - - - building closures - - -  - - - - -

+    (do ((part *to-do-fun-list* part))

+	((null? part))

+      (set! *lifted-closures-to-do* '())

+      (set! *passed-defs*

+	    (cons (try-closure-making-def(car part)) *passed-defs*))

+      (set! part (append *lifted-closures-to-do* (cdr part))))

+    (set! *to-do-fun-list* (reverse *passed-defs*))

+    (for-each lift-unmark-def! *to-do-fun-list*)

+    (if *infomessages-flag*

+        (begin (newline) (display "** Pass 2 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".cls"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *to-do-fun-list*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "closures-building file ")

+	  (display (string-append file '".cls"))

+	  (display " is built.")))

+    ;; closurebuilding pass completed

+    ;; - - - - - - - -   flattening starts  - - - - - - - - -

+    (set! *passed-defs* '())

+    (for-each (lambda (def)

+		(set! *passed-defs*

+		      (append (reverse (flatten-wholedef def))

+			      *passed-defs*)))

+	      *to-do-fun-list*)

+    (if (not (or (pair? *export-functions*) (null? *export-functions*)))

+	(set! *export-functions* *top-level-funs*)

+	(set! *export-functions*

+	      (intersection *export-functions* *top-level-funs*)))

+    (if *map1-needed-flag*

+	(set! *passed-defs* (cons *map1-definition* *passed-defs*)))

+    (if *for-each1-needed-flag*

+	(set! *passed-defs* (cons *for-each1-definition* *passed-defs*)))

+    (set! *passed-defs* (reverse *passed-defs*))

+    (if *infomessages-flag*

+	(begin (newline) (display "** Pass 3 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".flt"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *passed-defs*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "lambda-lifted & normalized definitions file ")

+	  (display (string-append file '".flt"))

+	  (display " is built.")))

+    (set! *to-do-fun-list* *passed-defs*)

+    ;; lambda-lifting & normalization finished

+    ;; - - - - - - - - - - lift statements - - - - - - - - - - -

+    (set! *passed-defs* '())

+    (do ((x 1 1))

+	((null? *to-do-fun-list*))

+      (let ((tmp (car *to-do-fun-list*)))

+	(set! *to-do-fun-list* (cdr *to-do-fun-list*))

+	(set! *passed-defs* (append (lift-statements-wholedef tmp)

+				    *passed-defs*))))

+    (set! *passed-defs* (reverse *passed-defs*))

+    (if *infomessages-flag*

+	(begin (newline) (display "** Pass 4 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".stt"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *passed-defs*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "statement-lifted definitions file ")

+	  (display (string-append file '".stt"))

+	  (display " is built.")))

+    (set! *to-do-fun-list* *passed-defs*)

+    ;; statement-lifting pass finished

+    ;; - - - - - - - hof-dot-corrections starts - - - - - -

+    (set! *passed-ho-dot-instfuns* '())

+    (set! *passed-defs* '())

+    (do ((x 1 1))

+	((null? *to-do-fun-list*))

+      (let ((tmp (car *to-do-fun-list*)))

+	(set! *to-do-fun-list* (cdr *to-do-fun-list*))

+	(if (not (memq (cadr tmp) *passed-ho-dot-instfuns*))

+	    (set! *passed-defs* (cons (ho-dot-wholedef tmp)

+				      *passed-defs*)))))

+    (set! *passed-defs*

+	  (reverse (append (build-wrappers *passed-defs*)

+			   *passed-defs*)))

+    (build-wrapped-interpreter-table)

+    (if *infomessages-flag*

+	(begin (newline) (display "** Pass 5 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".hod"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *passed-defs*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "higher-order-&-dot-arglist corrected definitions file ")

+	  (display (string-append file '".hod"))

+	  (display " is built.")))

+    (set! *to-do-fun-list* *passed-defs*)

+    ;; hof-dot correction finished

+    ;; - - - - - - - typing & constant-correcting - - - - - - - - - -

+    (set! *passed-defs* '())

+    (do ((x 1 1))

+	((null? *to-do-fun-list*))

+      (let ((tmp (car *to-do-fun-list*)))

+	(set! *to-do-fun-list* (cdr *to-do-fun-list*))

+	(set! *passed-defs* (cons (type-const-wholedef tmp)

+				  *passed-defs*))))

+

+    (for-each (lambda (x)

+		(let ((tmp (assq x *extra-hobbit-primitive-defs*)))

+		  (if (and tmp (not (memq x *modified-primitives*)))

+		      (begin

+			(set! *passed-defs*

+			      (cons (type-const-wholedef

+				     (list 'define x (cadr tmp)))

+				    *passed-defs*))

+			(if (memq x *extra-hobbit-dot-primitives*)

+			    (set! *dot-arg-templates*

+				  (cons (list x 'x) *dot-arg-templates*)))))))

+	      *unknown-vars*)

+    (set! *passed-defs* (reverse *passed-defs*))

+    (init-export-funs! file)

+    (make-initialization-function! file)

+    (if *infomessages-flag*

+	(begin (newline) (display "** Pass 6 completed **")))

+    (if *build-intermediate-files*

+	(let ((fport (open-output-file (string-append file '".typ"))))

+	  (for-each (lambda (x) (pretty-print x fport) (newline fport))

+		    *passed-defs*)

+	  (close-output-port fport)

+	  (newline)

+	  (display "typing & constants - corrected definitions file ")

+	  (display (string-append file '".typ"))

+	  (display " is built.")

+	  (newline)))

+    (set! *to-do-fun-list* *passed-defs*)

+    ;; typing & constant-correcting pass finished

+    ;; - - - - - - - - building .c and .h files  - - - - - - - - - -

+    (set! *passed-defs* '())

+    (let ((fport (open-output-file (string-append file '".c"))))

+      (display "#include " fport)

+      (display #\" fport)

+      (display (string-append file '".h") fport)

+      (display #\" fport)

+      (newline fport)

+      (newline fport)

+      (for-each (lambda (x) (write-c-wholefun x fport))

+		*to-do-fun-list*)

+      (close-output-port fport)

+      (if *infomessages-flag*

+	  (begin (newline) (newline)

+		 (display "C source file ")

+		 (display (string-append file '".c"))

+		 (display " is built.")

+		 (newline))))

+    (let ((fport (open-output-file (string-append file '".h"))))

+      (display-header fport)

+      (newline fport)

+      (for-each (lambda (x)

+		  (write-fun-declaration (cadr x) fport))

+		*to-do-fun-list*)

+      (for-each (lambda (x)

+		  (if (not (memq x *fast-vars-list*))

+		      (write-c-*declaration x fport)))

+		*global-vars-list*)

+      (for-each (lambda (x)

+		  (write-c-*declaration (cdr x) fport))

+		*interpreter-funname-table*)

+      (for-each (lambda (x)

+		  (write-c-*declaration (make-closure-scmobj-name x) fport))

+		*symbol-and-fun-list*)

+      (for-each (lambda (x)

+		  (write-c-static-declaration

+		   (make-closure-scmobj-name x) fport))

+		*lifted-trivial-closure-names*)

+      (for-each (lambda (x)

+		  (write-c-static-declaration

+		   (make-closure-scmobj-name x) fport))

+		*lifted-closure-names*)

+      (for-each (lambda (x) (write-c-static-declaration (cadr x) fport))

+		(reverse *symbol-constant-table*))

+      (for-each (lambda (x)

+		  (if (not (pair? (cadr x)))

+		      (write-c-static-declaration (cadr x) fport)))

+		(reverse *new-constant-list*))

+      (for-each (lambda (x)

+		  (write-c-*declaration

+		   (string->symbol

+		    (string-append (symbol->string x) *st-vector-postfix*))

+		   fport))

+		(reverse *stable-vector-names*))

+      (for-each (lambda (x) (write-c-static-declaration x fport))

+		(reverse *fast-vars-list*))

+      (newline fport)

+      (close-output-port fport)

+      (if *infomessages-flag*

+	  (begin

+	    (display "C header file ")

+	    (display (string-append file '".h"))

+	    (display " is built.")

+	    (newline))))

+    ;; .c and .h files built

+    ;; - - - - - - - - - extra compilation info: - - - - - - - - -

+    (set! *via-interpreter-defined*

+	  (append *via-interpreter-defined*

+		  (map car *switch-args-table*)

+		  *cxr-funs*

+		  *non-compiled-primitives*

+		  *interpreter-defined-vars*

+		  (map car *floats-s->c-fun-table*)))

+    ;; - - - - - - - - - redefinability info: - - - - - - - - -

+    (if *infomessages-flag* (newline))

+    (cond

+     ((not *infomessages-flag*))

+     (*all-funs-modified-flag*

+      (newline)

+      (display "All procedure names are assumed to be redefinable (slow).")

+      (newline))

+     (*new-funs-modified-flag*

+      (newline)

+      (display

+       "All new procedure names are assumed to be redefinable (slow).")

+      (newline)

+      (if (not (null? *modified-primitives*))

+	  (begin

+	    (display

+	     "These primitive procedure names are assumed to be redefinable (slow):")

+	    (newline)

+	    (display *modified-primitives*)

+	    (newline))))

+     (else

+      (if (not (null? *modified-primitives*))

+	  (begin

+	    (display

+	     "These primitive procedure names are assumed to be redefinable (slow):")

+	    (newline)

+	    (display *modified-primitives*)

+	    (newline)))

+      (if (not (null? (set-difference *modified-top-level-names*

+				      (union

+				       *global-vars-list* *fast-vars-list*))))

+	  (begin

+	    (display

+	     "These top level procedure names are assumed to be redefinable (slow):")

+	    (newline)

+	    (display (set-difference *modified-top-level-names*

+				     (union

+				      *global-vars-list* *fast-vars-list*)))

+	    (newline)))))

+    ;; - - - - - - - - - hof-info: - - - - - - - - - - - - - -

+    (cond

+     ((not *infomessages-flag*))

+     ((not (null? *non-liftable-hof-names*))

+      (display

+       "These top level higher order procedures are not clonable (slow):")

+      (newline)

+      (display *non-liftable-hof-names*)

+      (newline)))

+    ;; - - - - - - - - - closures-info: - - - - - - - - - - - - -

+    (cond

+     ((not *infomessages-flag*))

+     ((not (null? *not-all-liftable-names*))

+      (display

+       "These top level procedures create non-liftable closures (slow):")

+      (newline)

+      (display *not-all-liftable-names*)

+      (newline)))

+    ;; - - - - - - - - - undefined-info: - - - - - - - - - - -

+    (if (and *infomessages-flag*

+             (not (null?  (set-difference (set-difference *unknown-functions*

+							  *modified-top-level-names*)

+					  (union *global-vars-list*

+						 (union *fast-vars-list*

+							*via-interpreter-defined*))))))

+	(begin (newline)

+	       (display

+		"These nonprimitive procedures are assumed to be defined externally:")

+	       (newline)

+	       (display

+		(set-difference (set-difference *unknown-functions*

+						*modified-top-level-names*)

+				(union *global-vars-list*

+				       (union *fast-vars-list*

+					      *via-interpreter-defined*))))

+	       (newline)))

+    (if (and *infomessages-flag*

+             (not (null? (set-difference (set-difference *unknown-vars*

+							 *modified-top-level-names*)

+					 *via-interpreter-defined*))))

+	(begin (newline)

+	       (display

+		"These variables undefined (but used) in your file were defined:")

+	       (newline)

+	       (display (set-difference (set-difference *unknown-vars*

+							*modified-top-level-names*)

+					*via-interpreter-defined*))

+	       (newline)))

+    (if *infomessages-flag* (newline))))

+

+(define (sort-out-toplevel! lst file)

+  (set! *to-do-fun-list* '())

+  (set! *inline-funs* '())

+  (set! *inline-vars* '())

+  (set! *global-vars-list* '())

+  (set! *fast-vars-list* '())

+  (set! *var-make-list* '())

+  (set! *non-directcomp-list* '())

+  (set! *top-actions-list* '())

+  (do ((part lst (cdr part)))

+      ((null? part))

+    (let ((el (car part))

+	  (tmp '()))

+      (cond

+       ((and (list? el)

+	     (eq? 'begin (car el)))

+	(set! part (append el (cdr part))))

+       ((and (pair? el)

+	     (or (eq? 'load (car el))

+		 (eq? 'require (car el))))

+	(report-warning "ignoring a load on top level: " el))

+       ((or (not (pair? el))

+	    (not (eq? 'define (car el)))

+	    (null? (cdr el))

+	    (not (list? el)))

+	;; (report-error "the compiled file contains a non-definition: "

+	;;		   el)

+	;;  (if (pair? el)

+	;;	 (set! *non-directcomp-list* (cons el *non-directcomp-list*)))

+

+	(set! *top-actions-list* (cons el *top-actions-list*)))

+

+       ;; from here everything starts with 'define'.

+

+       ((or (pair? (cadr el))		; the standard direct function def

+	    (and (not (null? (cddr el)))

+		 (pair? (caddr el))

+		 (eq? 'lambda (car (caddr el)))))

+	;;(and (pair? (cddr el))

+	;;	    (pair? (caddr el))

+	;;	    (memq (car (caddr el)) '(let let* letrec))

+	;;	    (pair? (cddr (caddr el)))

+	;;	    (pair? (caddr (caddr el)))

+	;;	    (eq? 'lambda (car (caddr (caddr el)))))

+	;;	    ;(not (find-if (lambda (x) (not (eq? (car x) (cadr x))))

+	;;	    ;	       (cadr (caddr el))))

+	(let* ((def (normalize-top-define el))

+	       (funname (cadr def))

+	       (tmp '()))

+	  (if (modified-fun? funname)

+	      (set! *top-actions-list*

+		    (cons (cons 'set! (cdr def)) *top-actions-list*))

+	      (begin

+		(set! tmp (list *special-pseudoquote* funname))

+		(set! *top-actions-list* (cons tmp *top-actions-list*))

+		(set! *to-do-fun-list* (cons def *to-do-fun-list*))))))

+       ;; the following filters out macro defs:

+       ((and (pair? el)

+	     (pair? (cdr el))

+	     (eq? 'define (car el))

+	     (not (pair? (cadr el)))

+	     (pair? (cddr el))

+	     (pair? (caddr el))

+	     (eq? 'let (caaddr el))

+	     (pair? (car (my-last-pair (caddr el))))

+	     (eq? 'defmacro:transformer (caar (my-last-pair (caddr el))))))

+

+       ;; - - - from here everything will be a define-expression - - - -

+

+       ;;((and (pair? (caddr el))

+       ;;	(not (eq? 'quote (car (caddr el))))

+       ;;	(not (eq? 'quasiquote (car (caddr el)))))

+

+       ;;   (set! *top-actions-list*

+       ;;	   (cons (cons 'set! (cdr el)) *top-actions-list*)))

+

+       ;;(set! tmp (make-pair-constant (caddr el)))

+       ;;(set! *top-actions-list*

+       ;;	   (cons (list 'set! (cadr el) (list *actual-c-eval* tmp))

+       ;;		 *top-actions-list*))

+       ;; (set! *via-interpreter-defined*

+       ;;	   (cons (cadr el) *via-interpreter-defined*))

+

+       ;; - - - - - - - - - declarations-part starts - - - - - - - - -

+       ((eq? (cadr el) *inline-declare*)

+	(set! *inline-funs* (append (cadr (caddr el)) *inline-funs*)))

+       ((eq? (cadr el) *inline-vars-declare*)

+	(set! *inline-vars* (append (cadr (caddr el)) *inline-vars*)))

+       ((eq? (cadr el) *allnumbers-declare*)

+	(set! *floats-flag* el))

+       ((eq? (cadr el) *all-funs-modified-declare*)

+	(set! *all-funs-modified-flag* #t))

+       ((eq? (cadr el) *new-funs-modified-declare*)

+	(set! *new-funs-modified-flag* #t))

+       ((eq? (cadr el) *stable-vectors-declare*)

+	(set! *stable-vector-names*

+	      (append (cadr (caddr el))

+		      *stable-vector-names*)))

+       ((eq? (cadr el) *fast-vars-declare*)

+	(set! *fast-vars-list*

+	      (append (cadr (caddr el)) *fast-vars-list*)))

+       ((eq? (cadr el) *export-declare*)

+	(set! *export-functions*

+	      (append (cadr (caddr el))

+		      (if (pair? *export-functions*)

+			  *export-functions*

+			  '()))))

+       ;; - - - - - - - - -declarations-part ends - - - - - - - - - -

+       ((null? (cddr el))		; form: (define foo)

+	(set! *global-vars-list* (cons (cadr el) *global-vars-list*))

+	(set! *top-actions-list*

+	      (cons (list 'set! (cadr el) *unspecified*)

+		    *top-actions-list*))

+	(if (not (memq (cadr el) *fast-vars-list*))

+	    (set! *var-make-list*

+		  (cons `(set!

+			  ,(cadr el)

+			  (,*c-adr* (cdr (,*intern-function*

+					  (,*actual-c-string*

+					   ,(symbol->string (cadr el)))

+					  ,(string-length

+					    (symbol->string (cadr el)))))))

+			*var-make-list*))))

+

+       (else				; form: (define foo <term>)

+	(set! *global-vars-list* (cons (cadr el) *global-vars-list*))

+	(set! *top-actions-list*

+	      (cons (cons 'set! (cdr el)) *top-actions-list*))

+

+	;;(if (symbol? (caddr el))

+	;;	 ; the last el of define is a symbol; call intern:

+	;;	 (set! *top-actions-list*

+	;;	       (cons `(set!

+	;;                   ,(cadr el)

+	;;		       ,(list *actual-c-eval*

+	;;			      (make-pair-constant-aux (caddr el))))

+	;;(,*c-adr* (cdr (,*intern-function*

+	;;		       (,*actual-c-string*

+	;;			,(symbol->string (caddr el)))

+	;;		       (,*actual-c-int*

+	;;			,(string-length

+	;;			  (symbol->string

+	;;			   (caddr el)))))))

+	;;     *top-actions-list*))

+	;;	 ; the last el of define is a non-list non-symbol:

+	;;	 (set! *top-actions-list*

+	;;	       (cons (cons 'set! (cdr el))

+	;;		     *top-actions-list*)))

+	;;(set! *via-interpreter-defined*

+	;;	   (cons (cadr el) *via-interpreter-defined*))

+	(if (not (memq (cadr el) *fast-vars-list*))

+	    (set! *var-make-list*

+		  (cons `(set!

+			  ,(cadr el)

+			  (,*c-adr* (cdr (,*intern-function*

+					  (,*actual-c-string*

+					   ,(symbol->string (cadr el)))

+					  ,(string-length

+					    (symbol->string (cadr el)))))))

+			*var-make-list*)))))))

+  ;;(if (not (null? *top-actions-list*))

+  ;;    (set! *to-do-fun-list*

+  ;;	    (cons (list 'define

+  ;;			(make-globals-name file)

+  ;;			(list* 'lambda

+  ;;			       '()

+  ;;			       (reverse (cons '() *top-actions-list*))))

+  ;;		  *to-do-fun-list*)))

+

+  ;; - - - - - - - - making the top-actions-fun - - - - - - -- - -

+

+  (let* ((init-all-list (reverse *top-actions-list*))

+	 (init-all-splitted-lists (list '()))

+	 (fname '())

+	 (init-all-splitted-processed '())

+	 (top-actions-fun '())

+	 (split-nr 0))

+

+    ;; split up the big list

+    (do ((n 1 (+ n 1)))

+	((null? init-all-list))

+      (if (> n *max-auxfun-size*)

+	  (begin

+	    (set! n 1)

+	    (set! init-all-splitted-lists

+		  (cons '() init-all-splitted-lists))))

+      (set! init-all-splitted-lists

+	    (cons (cons (car init-all-list) (car init-all-splitted-lists))

+		  (cdr init-all-splitted-lists)))

+      (set!  init-all-list (cdr init-all-list)))

+

+    ;;(display "init-all-splitted-lists: ")

+    ;;(newline)

+    ;;(pretty-print init-all-splitted-lists)

+    ;;(newline)

+    (set! init-all-splitted-lists (reverse init-all-splitted-lists))

+    ;; process each sublist

+    (do ((lst init-all-splitted-lists (cdr lst)))

+	((null? lst))

+      (set! split-nr (+ 1 split-nr))

+      (set! fname

+	    (string->symbol

+	     (string-append  *top-actions-prefix*

+			     (string-append

+			      (number->string split-nr)

+			      "_"

+			      file))))

+      (set! *splitted-topaction-function-names*

+	    (cons fname *splitted-topaction-function-names*))

+      (set!  init-all-splitted-processed

+	     (cons

+	      (list 'define

+		    fname

+		    (list 'lambda

+			  '()

+			  (list* 'let* '() (reverse (car lst)))))

+	      init-all-splitted-processed)))

+

+    ;;(display "init-all-splitted-processed: ")

+    ;;(newline)

+    ;;(pretty-print init-all-splitted-processed)

+    ;;(newline)

+

+    (set! top-actions-fun

+	  (list

+	   'define (make-top-actions-funname file)

+	   (list* 'lambda '()

+		  (map list

+		       (reverse *splitted-topaction-function-names*)))))

+

+    (set! *to-do-fun-list*

+	  (cons top-actions-fun

+		(append init-all-splitted-processed

+			*to-do-fun-list*))))

+

+  ;; - - - - - - - - top-actions-fun is made and kept - - - - - - -

+  (set! *to-do-fun-list* (reverse *to-do-fun-list*))

+  (set! *non-directcomp-list* (reverse *non-directcomp-list*))

+  (set! *inline-funs-data* '())

+  (set! *inline-vars-data* '())

+  (do ((part *inline-vars* (cdr part)))

+      ((null? part))

+    (let ((tmp (member-if (lambda (x)

+			    (and (pair? x)

+				 (eq? 'set! (car x))

+				 (eq? (cadr x) (car part))))

+			  *top-actions-list*)))

+      (if tmp

+	  (set! *inline-vars-data*

+		(cons (cdar tmp) *inline-vars-data*))

+	  (set! *inline-vars* (remove (car part) *inline-vars*)))))

+  (do ((part *inline-funs* (cdr part)))

+      ((null? part))

+    (let ((tmp (member-if (lambda (x)

+			    (or (eq? (cadr x) (car part))

+				(and (pair? (cadr x))

+				     (eq? (caadr x) (car part)))))

+			  *to-do-fun-list*)))

+      (if tmp

+	  (set! *inline-funs-data*

+		(cons (list (car part)

+			    (make-inline-body (car tmp)))

+		      *inline-funs-data*))

+	  (set! *inline-funs* (remove (car part) *inline-funs*))))))

+

+

+

+(define (normalize-top-define term)

+  (if (or (not (pair? (cdr term)))

+	  (not (pair? (cddr term))))

+      (report-error "incorrect define: " term))

+  (if (pair? (cadr term))

+      `(define ,(caadr term) (lambda ,(cdadr term) ,@(cddr term)))

+      term))

+

+(define (make-inline-body def)

+  (let* ((tmp (rename-vars

+	       (lettify-lambdas

+		(normalize-defines

+		 (compile-quasiquote def))

+		200

+		#t)))

+	 (term (caddr tmp))

+	 (body (cddr term)))

+    (cond ((not (list? (cadr term)))

+	   (report-error "inline-function has a non-list arglist: "

+			 def))

+	  ((null? body)

+	   (report-error "inline-function has no body: " def))

+	  ((null? (cdr body))

+	   term)

+	  (else

+	   (list (car term)

+		 (cadr term)

+		 (cons 'begin body))))))

+

+

+(define (make-initialization-function! file)

+  (let* ((nondefines

+	  (map make-pair-constant *non-directcomp-list*))

+	 (vector-elts

+	  (map (lambda (x)

+		 `(set! ,(string->symbol

+			  (string-append

+			   (symbol->string x)

+			   *st-vector-postfix*))

+			(,*velts-function*

+			 (,*global-access* ,x))))

+	       *stable-vector-names*))

+	 (init-all-list

+	  (append

+	   (init-closure-funs file *passed-defs*)

+	   (init-interpretable-funs)

+	   *var-make-list*

+	   (reverse *symbol-list*)

+	   (reverse *new-constant-list*)

+	   (if (null? *top-actions-list*)

+	       '()

+	       (list

+		(list (make-top-actions-funname file))))

+	   vector-elts

+	   (map (lambda (x)

+		  (list *c-eval-fun* x))

+		nondefines)))

+	 (init-all-splitted-lists (list '()))

+	 (init-all-splitted-processed '())

+	 (split-nr 0)

+	 (main-fun '())

+	 (fname '()))

+

+

+    ;;(display "init-all-list: ")

+    ;;(newline)

+    ;;(pretty-print init-all-list)

+    ;;(newline)

+

+    ;; split up the big list

+    (do ((n 1 (+ n 1)))

+	((null? init-all-list))

+      (if (> n *max-auxfun-size*)

+	  (begin

+	    (set! n 1)

+	    (set! init-all-splitted-lists

+		  (cons '() init-all-splitted-lists))))

+      (set! init-all-splitted-lists

+	    (cons (cons (car init-all-list) (car init-all-splitted-lists))

+		  (cdr init-all-splitted-lists)))

+      (set!  init-all-list (cdr init-all-list)))

+

+    ;;(display "init-all-splitted-lists: ")

+    ;;(newline)

+    ;;(pretty-print init-all-splitted-lists)

+    ;;(newline)

+    (set! init-all-splitted-lists (reverse init-all-splitted-lists))

+    ;; process each sublist

+    (do ((lst init-all-splitted-lists (cdr lst)))

+	((null? lst))

+      (set! split-nr (+ 1 split-nr))

+      (set! fname

+	    (string->symbol

+	     (string-append *init-fun-prefix*

+			    (string-append

+			     (number->string split-nr)

+			     "_"

+			     file))))

+      (set! *splitted-init-function-names*

+	    (cons fname *splitted-init-function-names*))

+      (set!  init-all-splitted-processed

+	     (cons

+	      (list 'define

+		    fname

+		    (list 'lambda

+			  '()

+			  (list* 'let* '() (reverse (car lst)))))

+	      init-all-splitted-processed)))

+

+    ;;(display "init-all-splitted-processed: ")

+    ;;(newline)

+    ;;(pretty-print init-all-splitted-processed)

+    ;;(newline)

+

+    (set! main-fun

+	  (list 'define

+		(string->symbol (string-append *init-fun-prefix* file))

+		(list 'lambda

+		      '()

+		      (list* 'let* '()

+			     (map list

+				  (reverse *splitted-init-function-names*))))))

+

+    (set! *passed-defs*

+	  (append *passed-defs*

+		  (append (reverse init-all-splitted-processed)

+			  (list main-fun))))))

+

+

+(define (init-export-funs! file)

+  (let* ((res '())

+	 (topactions-funname (make-top-actions-funname file)))

+    (set! *export-functions*

+	  (remove (make-globals-name file) *export-functions*))

+    (for-each

+     (lambda (x)

+       (set! res (init-export-fun-aux x))

+       (if res

+	   (for-each

+	    (lambda (name)

+	      (let ((fun (car (member-if

+			       (lambda (x) (eq? (cadr x) name))

+			       *passed-defs*))))

+		(subst-term-equal!

+		 res (list *special-pseudoquote* (cadr x)) fun)))

+	    (cons topactions-funname

+		  *splitted-topaction-function-names*))))

+     *passed-defs*)))

+

+

+(define (init-export-fun-aux def)

+  (if (not (memq (cadr def) *export-functions*))

+      #f

+      (let* ((tmp1 (assq (cadr def) *export-table*))

+	     (tmp (assq (cadr def) *wrapper-table*))

+	     (arity '())

+	     (flag '())

+	     (res '()))

+	(cond (tmp (set! arity 'x))

+	      ((begin

+		 (set! arity (assq (cadr def) *dot-arg-templates*))

+		 (and arity

+		      (symbol? (cadr arity))))

+	       (set! arity 'x))

+	      (else (set! arity (cadr (caddr def)))))

+	(cond ((symbol? arity)

+	       (set! flag 'tc7_lsubr))

+	      (else

+	       (set! flag

+		     (cadr (assq (length arity)

+				 '((0 tc7_subr_0)

+				   (1 tc7_subr_1)

+				   (2 tc7_subr_2)

+				   (3 tc7_subr_3)))))))

+	(set! res

+	      (list 'make_subr

+		    (list *actual-c-string*

+			  (if (memq (cadr def) *symbol-and-fun-list*)

+			      (symbol->string

+			       (make-closure-scmobj-name (cadr def)))

+			      (symbol->string (cadr def))))

+		    flag

+		    (if tmp

+			(cadr tmp)

+			(if tmp1

+			    (cadr tmp1)

+			    (cadr def)))))

+	(if (memq (cadr def) *symbol-and-fun-list*)

+	    (set! res `(set! (,*global-access*

+			      ,(make-closure-scmobj-name (cadr def)))

+			     ,res)))

+	res)))

+

+

+(define (init-closure-funs file defs)

+  (append

+   (map

+    (lambda (funname)

+      (let* ((procname (make-closure-scmobj-name funname))

+	     (def-part '()))

+	(set! def-part (member-if (lambda (x) (eq? funname (cadr x))) defs))

+	`(set! ,procname ,(init-export-fun-aux (car def-part)))))

+    *lifted-trivial-closure-names*)

+   (map

+    (lambda (funname)

+      (let* ((procname (make-closure-scmobj-name funname)))

+	`(set! ,procname (make_subr (,*actual-c-string*

+				     ,(symbol->string procname))

+				    tc7_lsubr

+				    ,funname))))

+    *lifted-closure-names*)))

+

+

+(define (init-interpretable-funs)

+  (map

+   (lambda (x)

+     (list 'set! (cdr x)

+	   `(,*c-adr* (cdr (,*intern-function*

+			    (,*actual-c-string*

+			     ,(symbol->string (car x)))

+			    ,(string-length

+			      (symbol->string (car x))))))))

+   *interpreter-funname-table*))

+

+

+(define (make-globals-name file)

+  (string->symbol (string-append *init-globals-prefix* file)))

+

+(define (make-top-actions-funname file)

+  (string->symbol (string-append *top-actions-prefix* file)))

+

+(define (descmify str)

+  (let ((len (string-length str)))

+    (if (and (> len 4)

+	     (string-ci=? ".scm" (substring str (- len 4) len)))

+	(substring str 0 (- len 4))

+	str)))

+

+

+

+

+(define (display-header fport)

+  (define *h-port* fport)

+  (define (headerline s)

+    (display s *h-port*)

+    (newline *h-port*))

+  (if *floats-flag* (headerline "#define FLOATS"))

+  (headerline "#include \"scmhob.h\"")

+  (headerline ""))

+

+(define (init-global)

+   (set! *floats-flag* #f)

+   (set! *tmp-vars* '())

+   (set! *new-fun-names* '())

+   (set! *new-fun-nr* 0)

+   (set! *higher-order-funs* '())

+   (set! *higher-order-templates* '())

+   (set! *new-parameter-nr* '0)

+   (set! *dot-arg-funs* '())

+   (set! *dot-arg-templates* '())

+   (set! *new-instnr* '0)

+   (set! *new-primitive-instnr* '0)

+   (set! *new-constant-list* '())

+   (set! *symbol-constant-table* '())

+   (set! *interpreter-funname-table* '())

+   (set! *new-constant-num* 0)

+   (set! *char-replacements-lists* '())

+   (set! *splitted-init-function-names* '())

+   (set! *splitted-topaction-function-names* '())

+   (set! *map1-needed-flag* #f)

+   (set! *for-each1-needed-flag* #f)

+   (set! *symbol-list* '())

+   (set! *unknown-functions* '())

+   (set! *unknown-vars* '())

+   (set! *top-level-funs* '())

+   (set! *inline-funs* '())

+   (set! *inline-vars* '())

+   (set! *export-functions* #f)

+   (set! *export-table* '())

+   (set! *wrapper-table* '())

+   (set! *stable-vector-names* '())

+   (set! *fast-vars-list* '())

+   (set! *closure-var-vectornames* '())

+   (set! *lifted-closures-to-do* '())

+   (set! *lifted-trivial-closure-names* '())

+   (set! *lifted-closure-names* '())

+   (set! *via-interpreter-defined* '())

+   (set! *special-c-vars* '())

+   (set! *closure-name-nr* 0)

+   (set! *closure-vector-name-nr* 0)

+   (set! *liftable-hof-database* '())

+   (set! *letrec-closure-nr* 0)

+   (set! *not-all-liftable-names* '())

+   (set! *all-funs-modified-flag* #f)

+   (set! *new-funs-modified-flag* #f)

+   (set! *symbol-and-fun-list* '())

+   (set! *hobbit-declaration-vars*

+	 (list *inline-declare* *inline-vars-declare* *allnumbers-declare*

+	       *all-funs-modified-declare* *new-funs-modified-declare*

+	       *export-declare* *stable-vectors-declare* *fast-vars-declare*))

+   (set! *primitives*

+	 (append (map car *switch-args-table*)

+		 *cxr-funs*

+		 *non-compiled-primitives*

+		 (map car *floats-s->c-fun-table*)))

+   (do ((nr 1 (+ 1 nr)))

+       ((= nr *tmp-var-max*))

+       (set! *tmp-vars*

+	     (cons (string->symbol (string-append  *tmp-var-name*

+						   (number->string nr)))

+		   *tmp-vars*)))

+   (set! *tmp-vars* (reverse *tmp-vars*)))

+

+

+;; set-primitive-tables sets tables differently for the float and non-float case

+

+(define (set-primitive-tables)

+ (set! *num-arg-c-funs*

+       (append

+	(if *badivsgns-flag*

+	    '()

+	    '(quotient remainder))

+	(if *floats-flag*

+	    '()

+	    '(/))

+	'(logxor lognot logsleft logsright

+		 = < > <= >= + - *

+		 %= %< %> %<= %>= %+ %- %* %/)))

+ (set! *always-num-arg-c-funs*

+	;;if *badivsgns-flag*

+	;;   '()

+	;;   '(quotient remainder))

+	'(logxor lognot logsleft logsright

+		 %= %< %> %<= %>= %+ %- %* %/))

+ (set! *num-res-c-funs*

+       (append

+	(if *badivsgns-flag*

+	    '()

+	    '(quotient remainder))

+	(if *floats-flag*

+	    '()

+	    '(/))

+       '(logxor lognot logsleft logsright

+		+ - *

+		%+ %- %* %/)))

+ (set! *bool-arg-c-funs*

+       (cons *and?* (cons *or?* (list *not?*))))

+ (set! *always-bool-res-c-funs*

+       (cons *and?*

+	     (cons *or?*

+		   (cons *not?*

+			 '(boolean? symbol? char? vector? pair?

+			    string? number? complex?

+			    eq? char=? null?

+			    %eqv? %zero? %negative? %positive? %number?

+			    %= %< %> %<= %>= )))))

+ (set! *bool-res-c-funs*

+       (cons *and?*

+	     (cons *or?*

+		   (cons *not?*

+		      '(boolean? symbol? char? vector? pair?

+		       string? number? real? rational? complex?

+		       integer?

+		       eq? eqv? char=? null? zero? negative? positive?

+		       = < > <= >=

+		       %eqv? %zero? %negative? %positive? %number?

+		       %= %< %> %<= %>= ))))))

+

+

+(define (report-warning . lst)

+  (display #\newline)

+  (display "COMPILER WARNING: ")

+  (display #\newline)

+  (for-each display lst)

+  (display #\newline))

+

+;;=================================================================

+;;

+;;		  final conversion to C

+;;

+;;=================================================================

+

+(define (write-c-*declaration var port)

+   (set! *c-port* port)

+   (display-c *scm-type*)

+   (display-c #\space)

+   (display-c #\*)

+   (display-c-var var)

+   (display-c #\;)

+   (display-c-newline))

+

+(define (write-fun-declaration var port)

+   (set! *c-port* port)

+   (display-c *scm-type*)

+   (display-c #\space)

+   (display-c-var var)

+   (display-c "()")

+   (display-c #\;)

+   (display-c-newline))

+

+(define (write-c-static-declaration var port)

+   (set! *c-port* port)

+   (display-c "static ")

+   (display-c *scm-type*)

+   (display-c #\space)

+   (display-c-var var)

+   (display-c #\;)

+   (display-c-newline))

+

+

+(define (write-c-wholefun def port)

+  (let* ((fun (caddr def))

+	 (top-let (caddr fun)))

+    (set! *c-port* port)

+    (set! *current-fun-name* (cadr def))

+    (display-c *scm-type*)

+    (display-c #\space)

+    (display-c-var (cadr def))

+    (display-c-lst (args->list (cadr fun)) #\( #f)

+    (display-c-newline)

+    (if (not (null? (cadr fun)))

+	(begin

+	  (let ((scm-args (filter (lambda (x) (symbol? x)) (cadr fun)))

+		(fun-args (filter (lambda (x)

+				    (and (pair? x) (eq? *function* (car x))))

+				  (cadr fun)))

+		(ptr-args (filter (lambda (x)

+				    (and (pair? x) (eq? *c-adr* (car x))))

+				  (cadr fun))))

+	    (if (not (null? ptr-args))

+		(begin

+		  (display-c *scm-type*)

+		  (display-c #\space)

+		  (display-c-lst (map cadr ptr-args) #f #\*)

+		  (display-c #\;)

+		  (display-c-newline)))

+	    (if (not (null? fun-args))

+		(begin

+		  (display-c *scm-type*)

+		  (display-c #\space)

+		  (display-c-lst (map cadr fun-args) #f 'function)

+		  (display-c #\;)

+		  (display-c-newline)))

+	    (if (not (null? scm-args))

+		(begin

+		  (display-c *scm-type*)

+		  (display-c #\space)

+		  (display-c-lst scm-args #f #f)

+		  (display-c #\;)

+		  (display-c-newline))))))

+    (display-c #\{)

+    (display-c-newline)

+    (if (and (not (null? (cadr top-let)))

+	     (find-if (lambda (x) (symbol? (car x))) (cadr top-let)))

+	(begin

+	  (display-c-indent 1)

+	  (display-c *scm-type*)

+	  (display-c #\space)

+	  (display-c-lst (filter (lambda (x) (symbol? x))

+				 (map car (cadr top-let)))

+			 #f #f)

+	  (display-c #\;)

+	  (display-c-newline)

+	  (display-c-newline)))

+    (for-each (lambda (x)

+		(display-c-statement x 1))

+	      (cddr top-let))

+    (display-c #\})

+    (display-c-newline)

+    (display-c-newline)))

+

+(define (display-c x)

+   (display x *c-port*))

+

+

+;;(define (write-c-string x)

+;;   (write x *c-port*))

+

+(define (write-c-string x)

+  (display "\"" *c-port*)

+  (for-each

+   (lambda (c)

+     (cond

+      ((eq? c #\nl) (display "\\n" *c-port*))

+      ((eq? c #\")  (display "\\\"" *c-port*))

+      ((eq? c #\ht) (display "\\t" *c-port*))

+      ((eq? c #\\)  (display "\\\\" *c-port*))

+      (else (display c *c-port*))))

+   (string->list x))

+  (display "\"" *c-port*))

+

+

+(define (display-c-newline)

+   (newline *c-port*))

+

+(define (display-c-indent n)

+  (do ((m 0 (+ 1 m)))

+      ((= n m))

+      (display-c *c-indent*)))

+

+(define (display-c-lst lst par prefix)

+ (let ((separator #\,))

+  (cond ((char=? par #\()

+	    (set! separator #\,)

+	    (display-c #\())

+	((char=? par #\{)

+	    (set! separator #\;)

+	    (display-c #\{))

+	(else

+	    (set! separator #\,)))

+  (if (not (null? lst))

+      (begin

+	(for-each (lambda (x)

+		    (cond ((and (pair? x)

+				(eq? 'set! (car x))

+				(eq? 3 (length x))

+				(eq? *dummy* (caddr x))))

+		          ((or (char? prefix) (string? prefix))

+			     (display-c prefix)

+			     (display-c-expression x #t)

+			     (display-c separator))

+			  ((eq? 'function prefix)

+			     (display-c "(*")

+			     (display-c-expression x #t)

+			     (display-c ") ()")

+			     (display-c separator))

+			  (else

+			     (display-c-expression x #t)

+			     (display-c separator))))

+		  (butlast lst 1))

+	(cond ((or (char? prefix) (string? prefix))

+		 (display-c prefix)

+		 (display-c-expression (car (my-last-pair lst)) #t))

+	      ((eq? 'function prefix)

+		 (display-c "(*")

+		 (display-c-expression (car (my-last-pair lst)) #t)

+		 (display-c ") ()"))

+	      (else

+		 (display-c-expression (car (my-last-pair lst)) #t)))))

+  (cond ((char=? par #\()

+	    (display-c #\)))

+	((char=? par #\{)

+	    (display-c #\;)

+	    (display-c #\})))))

+

+

+

+

+(define (display-var var port)

+ (cond

+  ((eq? *listofnull* var)

+     (display "listofnull" port))

+  ((eq? *unspecified* var)

+     (display "UNSPECIFIED" port))

+  (else

+   (let* ((str (symbol->string var))

+	  (char '())

+	  (replacement '())

+	  (len (string-length str))

+	  (global-flag #f))

+     (if (and (symbol? var)

+	      (char-numeric? (string-ref str 0)))

+	 (display *c-num-symb-prefix* port))

+     (if (and (char=? #\* (string-ref str 0))

+	      (char=? #\* (string-ref str (- len 1))))

+	 (set! global-flag #t))

+     (do ((n 0 (+ 1 n)))

+	 ((= n len))

+       (set! char (string-ref str n))

+       (cond ((and global-flag

+		   (or (= 0 n) (= n (- len 1))))

+	      char) ; do nothing

+	     ((char-alphabetic? char)

+	      (display (char-downcase char) port))

+	     ((char-numeric? char)

+	      (display char port))

+	     ((begin

+		(set! replacement (assoc char *char-replacements*))

+		replacement)

+	      (display (cadr replacement) port))

+	     (else

+	      (display char port))))

+     (cond ((memq var *c-keywords*)

+	    (display *c-keyword-postfix* port))

+	   (global-flag

+	    (display *global-postfix* port)))))))

+

+

+(define (display-c-var var)

+  (display-var var *c-port*))

+

+

+(define (display-c-statement term n)

+  (let ()

+    (cond ((not (pair? term)))

+	  ;;   (display-c-indent n)

+	  ;;   (display-c #\;) ; empty operator

+	  ;;   (display-c-newline))

+	  ((eq? 'if (car term))

+	   (display-c-indent n)

+	   (display-c "if(")

+	   (display-c-expression (cadr term) #t)

+	   (display-c #\))

+	   (cond ((not (pair? (caddr term)))

+		  (display-c #\space)

+		  (display-c #\;)	; empty operator

+		  (display-c-newline))

+		 ((and (not (eq? 'begin (car (caddr term))))

+		       (not (eq? 'if (car (caddr term)))))

+		  (display-c-newline)

+		  (display-c-statement (caddr term) (+ 1 n)))

+		 ((eq? 'begin (car (caddr term)))

+		  (display-c #\space)

+		  (display-c #\{)

+		  (display-c-newline)

+		  (for-each (lambda (x) (display-c-statement x (+ 1 n)))

+			    (cdar (cddr term)))

+		  (display-c-indent n)

+		  (display-c #\})

+		  (display-c-newline))

+		 ((eq? 'if (car (caddr term)))

+		  (display-c #\space)

+		  (display-c #\{)

+		  (display-c-newline)

+		  (display-c-statement (car (cddr term)) (+ 1 n))

+		  (display-c-indent n)

+		  (display-c #\})

+		  (display-c-newline))

+		 (else (report-error "wrong syntax: " term)))

+	   (cond ((null? (cdddr term)))	; do nothing

+		 ((not (pair? (car (cdddr term))))) ; do nothing

+		 ((and (not (eq? 'begin (caar (cdddr term))))

+		       (not (eq? 'if (caar (cdddr term)))))

+		  (display-c-indent n)

+		  (display-c "else")

+		  (display-c-newline)

+		  (display-c-statement (car (cdddr term)) (+ 1 n)))

+		 ((eq? 'begin (caar (cdddr term)))

+		  (display-c-indent n)

+		  (display-c "else")

+		  (display-c #\space)

+		  (display-c #\{)

+		  (display-c-newline)

+		  (for-each (lambda (x) (display-c-statement x (+ 1 n)))

+			    (cdar (cdddr term)))

+		  (display-c-indent n)

+		  (display-c #\})

+		  (display-c-newline))

+		 ((eq? 'if (caar (cdddr term)))

+		  (display-c-indent n)

+		  (display-c "else")

+		  (display-c-newline)

+		  (display-c-statement (car (cdddr term)) n))))

+	  ((eq? (car term) *do-not*)

+	   (display-c-indent n)

+	   (display-c "for(")

+	   (let ((lst1 (map (lambda (x) (list 'set! (car x) (cadr x)))

+			    (cadr term)))

+		 (lst2 (map (lambda (x) (list 'set! (car x) (caddr x)))

+			    (filter (lambda (y) (not (null? (cddr y))))

+				    (cadr term)))))

+	     (if (not (null? lst1))

+		 (display-c-lst lst1 #f #f))

+	     (display-c #\;)

+	     (if (> (length lst1) 1)

+		 (begin

+		   (display-c-newline) (display-c-indent n) (display-c "    ")))

+	     (display-c-expression (caar (cddr term)) #t)

+	     (display-c #\;)

+	     (if (and (> (length lst1) 1) (not (null? lst2)))

+		 (begin

+		   (display-c-newline) (display-c-indent n) (display-c "    ")))

+	     (if (not (null? lst2))

+		 (display-c-lst lst2 #f #f))

+	     (display-c #\))

+	     (cond ((or (null? (cdddr term))

+			(not (find-if (lambda (x) (pair? x)) (cdddr term))))

+		    (display-c #\space)

+		    (display-c #\;)	; empty operator

+		    (display-c-newline))

+		   ((null? (cdr (cdddr term)))

+		    (if (or (eq? 'begin (caar (cdddr term)))

+			    (eq? *op-begin* (caar (cdddr term))))

+			(begin

+			  (display-c #\space)

+			  (display-c #\{)

+			  (display-c-newline)

+			  (for-each (lambda (x)

+				      (display-c-statement x (+ 1 n)))

+				    (cdar (cdddr term)))

+			  (display-c-indent n)

+			  (display-c #\})

+			  (display-c-newline))

+			(begin

+			  (display-c-newline)

+			  (display-c-statement (car (cdddr term))

+					       (+ 1 n)))))

+		   (else

+		    (display-c #\space)

+		    (display-c #\{)

+		    (display-c-newline)

+		    (for-each (lambda (x)

+				(display-c-statement x (+ 1 n)))

+			      (cdddr term))

+		    (display-c-indent n)

+		    (display-c #\})

+		    (display-c-newline)))))

+	  ((or (eq? (car term) 'begin) (eq? (car term) *op-begin*))

+	   (display-c-indent n)

+	   (display-c #\{)

+	   (display-c-newline)

+	   (for-each (lambda (x) (display-c-statement x (+ 1 n)))

+		     (cdr term))

+	   (display-c-indent n)

+	   (display-c #\})

+	   (display-c-newline))

+	  ((eq? (car term) *return*)

+	   (display-c-indent n)

+	   (display-c "return ")

+	   (display-c-expression (cadr term) #t)

+	   (display-c #\;)

+	   (display-c-newline))

+	  ((or (eq? *tailrec* (car term)) (eq? *mark-tailrec* (car term)))

+	   (display-c "tailrecursion:")

+	   (display-c-newline))

+	  ((eq? *goto-tailrec* (car term))

+	   (display-c-indent n)

+	   (display-c "goto tailrecursion;")

+	   (display-c-newline))

+	  ((and (eq? 'set! (car term))

+		(eq? *dummy* (caddr term)))) ; do nothing

+	  (else

+	   (display-c-indent n)

+	   (display-c-expression term)

+	   (display-c #\;)

+	   (display-c-newline)))))

+

+(define (display-c-expression term . no-par-flag)

+  (let ((fn (if (pair? term) (car term) '()))

+	(args (if (pair? term) (cdr term) '()))

+	(tmp #f))

+   (cond

+     ((symbol? term)

+	(display-c-var term))

+     ((number? term)

+	(display-c term)

+	(if *long-cast-flag* (display-c "L")))

+     ((boolean? term)

+	(if term (display-c *c-true*) (display-c *c-false*)))

+     ((char? term)

+	(if (printable-char? term)

+	    (begin

+	      (display-c #\')

+	      (display-c term)

+	      (display-c #\'))

+	    (display-c (char->integer term))))

+     ((null? term)

+	(display-c *c-null*))

+     ((not (pair? term))

+	(report-error "wrong type of object for C: " term))

+     ((and (eq? *bool-c->s* fn)

+	   (boolean? (car args)))

+	(if (car args)

+	    (display-c "BOOL_T")

+	    (display-c "BOOL_F")))

+     ((eq? *c-adr* fn)

+	(display-c #\&)

+	(display-c-expression (car args)))

+     ((eq? *c-fetch* fn)

+	(display-c #\*)

+	(display-c-expression (car args)))

+     ((eq? fn *higher-order-call*)

+	(display-c "(*")

+	(display-c-var (car args))

+	(display-c ")")

+	(display-c-lst (cdr args) #\( #f))

+     ((eq? *function* fn)

+	(display-c-expression (car args)))

+     ((or (eq? fn 'begin) (eq? fn *op-begin*))

+	(display-c-lst args #\( #f))

+     ((eq? fn *op-if*)

+	(display-c #\()

+	(display-c-expression (car args))

+	(display-c " ? ")

+	(display-c-expression (cadr args))

+	(display-c " : ")

+	(display-c-expression

+	   (if (null? (cddr args))

+	       *unspecified*

+	       (caddr args)))

+	(display-c #\)))

+     ((eq? fn *actual-c-string*)

+	(display-c "(char *)")

+	(write-c-string (car args)))

+     ((eq? fn *actual-c-expr*)

+	(display-c (car args)))

+     ((eq? fn *actual-c-int*)

+	(display-c (car args)))

+     ((eq? fn *actual-c-eval*)

+        (display-c "eval(")

+	(display-c-var (car args))

+	(display-c ")"))

+     ((eq? 'set! fn)

+	(or (eq? *dummy* (cadr args))

+	    (begin  (display-c-expression (car args))

+		    (display-c *c-infix-surround*)

+		    (display-c "=")

+		    (display-c *c-infix-surround*)

+		    (display-c-expression (cadr args)))))

+     ((begin (set! tmp (assq fn *switch-args-table*))

+	     tmp)

+	(display-c-expression (cons (cadr tmp) (reverse args))))

+     ((and (begin (set! tmp (assq fn *add-args-table*))

+		  tmp)

+	   (not (= (length args) (caddr tmp))))

+	 (display-c-expression

+	       (cons fn (append args (list (cadr tmp))))))

+

+     ((begin (if (memq fn '(vector string))

+		 (set! args (list (normalize-list-for-c args))))

+	     #f)) ; never succeeds

+     ((begin (set! tmp (if *floats-flag*

+			   (assq fn *floats-s->c-fun-table*)

+			   (assq fn *reckless-s->c-fun-table*)))

+	     tmp)

+	(cond ((and (not (null? (cdddr tmp)))

+		    (car (cdddr tmp)))

+		 (if (or (null? no-par-flag)

+			 (not (car no-par-flag)))

+		     (display-c #\())

+		 (display-c-expression (car args))

+		 (display-c *c-infix-surround*)

+		 (display-c (cadr tmp))

+		 (display-c *c-infix-surround*)

+		 (display-c-expression (cadr args))

+		 (if (or (null? no-par-flag)

+			 (not (car no-par-flag)))

+		     (display-c #\))))

+	      (else

+		 (display-c (cadr tmp))

+		 (display-c-lst args #\( #f))))

+     (else

+	(display-c-expression fn)

+	(display-c-lst args #\( #f)))))

+

+

+

+(define (printable-char? chr)

+  (or (char-alphabetic? chr)

+      (char-numeric? chr)

+      (memq chr '(#\! #\@ #\$ #\% #\^ #\& #\* #\( #\)

+		  #\_ #\+ #\| #\- #\=

+		  #\{ #\} #\[ #\]

+		  #\; #\, #\. #\/

+		  #\: #\" #\~ #\< #\> #\?

+		  #\space))))

+

+

+(define *non-compiled-primitives*

+  '(apply call-with-current-continuation apply force delay load

+	  map for-each list call-with-input-file call-with-output-file

+	  open-input-file open-output-file with-input-from-file

+	  with-output-to-file string-append

+	  logical:logxor logical:lognot logical:logior logical:logand

+	  logical:ash logical:logcount logical:integer-length

+	  logical:bit-extract logical:integer-expt

+	  defmacro:expand*

+	  sin cos tan asin acos atan sinh cosh tanh asinh acosh

+	  sin cos tan asin acos atan sinh cosh tanh asinh acosh

+	  atanh sqrt expt integer-expt))

+

+(define *interpreter-defined-vars* '())

+;; '(*features*

+;;    most-positive-fixnum  most-negative-fixnum))

+

+;; defs in *extra-hobbit-primitive-defs* are used when the extra primitive

+;; is passed as an argument.

+

+(define *extra-hobbit-dot-primitives* '(%+ %- %* %/ %= %< %> %<= %>=))

+

+(define *extra-hobbit-primitive-defs*

+  '((logsleft  (lambda (x y) (**return** (ash x y))))

+    (logsright (lambda (x y) (**return** (ash x (- y)))))

+    (%+ (lambda (x)

+          (let* ((r 0))

+	    (do ((l x (cdr x))) ((null? l) (**return** r))

+	      (set! r (%+ r (car l)))))))

+    (%- (lambda (x)

+          (let* ((r 0))

+	    (do ((l x (cdr x))) ((null? l) (**return** r))

+	      (set! r (%- r (car l)))))))

+    (%* (lambda (x)

+          (let* ((r 1))

+	    (do ((l x (cdr x))) ((null? l) (**return** r))

+	      (set! r (%* r (car l)))))))

+    (%/ (lambda (x)

+          (let* ((r 1))

+	    (do ((l x (cdr x))) ((null? l) (**return** r))

+	      (set! r (%/ r (car l)))))))

+    (%= (lambda (x)

+          (let* ((r #t))

+	    (do ((l x (cdr x)))

+		((or (not r) (null? l) (null? (cdr l))) (**return** r))

+	      (if (not (%= (car l) (cadr l)))

+		  (set! r #f))))))

+    (%< (lambda (x)

+          (let* ((r #t))

+	    (do ((l x (cdr x)))

+		((or (not r) (null? l) (null? (cdr l))) (**return** r))

+	      (if (not (%< (car l) (cadr l)))

+		  (set! r #f))))))

+    (%> (lambda (x)

+          (let* ((r #t))

+	    (do ((l x (cdr x)))

+		((or (not r) (null? l) (null? (cdr l))) (**return** r))

+	      (if (not (%> (car l) (cadr l)))

+		  (set! r #f))))))

+    (%>= (lambda (x)

+	   (let* ((r #t))

+	     (do ((l x (cdr x)))

+		 ((or (not r) (null? l) (null? (cdr l))) (**return** r))

+	       (if (not (%>= (car l) (cadr l)))

+		   (set! r #f))))))

+    (%<= (lambda (x)

+	   (let* ((r #t))

+	     (do ((l x (cdr x)))

+		 ((or (not r) (null? l) (null? (cdr l))) (**return** r))

+	       (if (not (%<= (car l) (cadr l)))

+		   (set! r #f))))))))

+

+(define *switch-args-table*

+  '((char>? char<?) (char-ci>? char-ci<?)

+    (char>=? char<=?) (char-ci>=?  char-ci<=?)

+    (string>?  string<?) (string-ci>? string-ci<?)

+    (string-ci>=? string-ci<=?) (string>=? string<=?)))

+

+(define *add-args-table*

+  (append

+   (list

+    (list 'make-vector '() 2)

+    (list 'number->string (list *num-c->s* 10) 2)

+    (list 'string->number (list *num-c->s* 10) 2)

+    (list 'make-string (list *actual-c-expr* "MAKICHR(' ')") 2))

+   '((quit 1 1)

+     (read (current-input-port) 1)

+     (read-char (current-input-port) 1)

+     (peek-char (current-input-port) 1)

+     (write (current-output-port) 2)

+     (display (current-output-port) 2)

+     (newline (current-output-port) 1)

+     (write-char (current-output-port) 2))))

+

+(define *standard-s->c-fun-table*

+  (append

+   (list (list 'force (symbol->string *force-function*) 1))

+   '((%eqv?     "=="       2 #t #t)

+     (%zero?    "ZERO_P"    1 #f #t)

+     (%positive? "POSITIVE_P" 1 #f #t)

+     (%negative? "NEGATIVE_P" 1 #f #t)

+     (%=	"=="       2 #t #t)

+     (%<	"<"	2 #t #t)

+     (%>	">"	2 #t #t)

+     (%<=       "<="       2 #t #t)

+     (%>=       ">="       2 #t #t)

+     (%+	"+"	2 #t #t)

+     (%-	"-"	2 #t #t)

+     (%*	"*"	2 #t #t)

+     (%/	"lquotient"  2 #f #f)

+     (cons "cons" 2) (car "CAR" 1) (cdr "CDR" 1)

+     (acons "acons" 3)

+     (list? "listp" 1) (length "length" 1) (append "append2" 2)

+     (reverse "reverse" 1) (list-tail "list_tail" 2) (list-ref "list_ref" 2)

+     (memq "memq" 2) (member "member" 2) (memv "memv" 2)

+     (assq "assq" 2) (assv "assv" 2) (assoc "assoc" 2)

+

+     (symbol->string "symbol2string" 1) (string->symbol "string2symbol" 1)

+     (system "lsystem" 1)

+     (verbose "prolixity" 1)

+     (copy-tree "copytree" 1)

+     (@copy-tree "copytree" 1)

+

+     (exact? "exactp" 1) (inexact? "inexactp" 1)

+     (odd? "oddp" 1) (even? "evenp" 1) (max "lmax" 2) (min "lmin" 2) (abs "absval" 1)

+     (quotient "lquotient" 2) (remainder "lremainder" 2)

+     (modulo "modulo" 2) (gcd "lgcd" 2) (lcm "llcm" 2)

+

+     (exact->inexact "EX2IN_FUN" 1) (floor "FLOOR_FUN" 1)

+     (ceiling "CEILING_FUN" 1)

+     (truncate "TRUNCATE_FUN" 1) (round "ROUND_FUN" 1)

+     ($sin "SIN_FUN" 1) ($cos "COS_FUN" 1) ($tan "TAN_FUN" 1)

+     ($asin "ASIN_FUN" 1)

+     ($acos "ACOS_FUN" 1) ($atan "ATAN_FUN" 1) ($sinh "SINH_FUN" 1)

+     ($cosh "COSH_FUN" 1)

+     ($tanh "TANH_FUN" 1) ($asinh "ASINH_FUN" 1) ($acosh "ACOSH_FUN" 1)

+     ($atanh "ATANH_FUN" 1)

+     ($sqrt "SQRT_FUN" 1) ($expt "EXPT_FUN" 2)

+     ($log "LOG_FUN" 1) ($abs "ABS_FUN" 1) ($exp "EXP_FUN" 1)

+

+     (inexact->exact "in2ex" 1)

+     (make-rectangular "makrect" 2) (make-polar "makpolar" 2)

+     (real-part "real_part" 1) (imag-part "imag_part" 1)

+     (magnitude "magnitude" 1) (angle "angle" 1)

+

+     (number->string "number2string" 2) (string->number "string2number" 1)

+

+     (char<? "CHAR_LESSP" 2) (char<=? "CHAR_LEQP" 2)

+     (char-ci=? "CHCI_EQ" 2) (char-ci<? "CHCI_LESSP")

+     (char-ci<=? "CHCI_LEQP" 2)

+

+     (char-alphabetic? "CHAR_ALPHAP" 1) (char-numeric? "CHAR_NUMP" 1)

+     (char-whitespace? "CHAR_WHITEP" 1) (char-upper-case? "CHAR_UPPERP" 1)

+     (char-lower-case? "CHAR_LOWERP" 1)

+

+     (char->integer "CHAR2INT" 1) (integer->char "INT2CHAR" 1)

+     (char-upcase "CHAR_UPCASE" 1) (char-downcase "CHAR_DOWNCASE" 1)

+

+     (make-string "make_string" 2)

+     (string "string" 1)

+     (string-length "ST_LENGTH" 1)

+     (string-ref "ST_REF" 2)

+     (string-set! "st_set" 3)

+     (substring "substring" 3)

+     (string-append "st_append" 1)

+     (list->string "string" 1)

+     (string->list "string2list" 1)

+     (string-copy "string_copy" 1)

+     (string-fill! "string_fill" 2)

+     (string=? "st_equal" 2) (string<? "st_lessp" 2) (string<=? "st_leqp" 2)

+     (string-ci=? "stci_equal" 2) (string-ci<? "stci_lessp")

+     (string-ci<=? "stci_leqp" 2)

+

+     (make-vector "make_vector" 2)

+     (vector "vector" 1)

+     (vector-length "VECTOR_LENGTH" 1)

+

+     (vector-ref "vector_ref" 2)

+     (vector-set! "vector_set" 3)

+     (vector->list "vector2list" 1)

+     (list->vector "vector" 1)

+

+     (read "lread" 1)

+     (read-char "scm_read_char" 1)

+     (peek-char "peek_char" 1)

+     (eof-object? "eof_objectp" 1)

+     (write "lwrite" 2)

+     (display "display" 2)

+     (newline "newline" 1)

+     (write-char "write_char" 2)

+

+     (input-port? "input_portp" 1)

+     (output-port? "output_portp" 1)

+     (current-input-port "cur_input_port" 0)

+     (current-output-port "cur_output_port" 0)

+     (close-input-port "close_port" 1)

+     (close-output-port "close_port" 1)

+

+     (get-internal-run-time "my_time" 0)

+     (quit "quit" 1)

+     (abort "abrt" 0)

+     (restart "restart" 0)

+     (chdir "chdir" 1)

+     (delete-file "del_fil" 1)

+     (rename-file "ren_fil" 2))))

+

+

+ ;;; (<s-fn> <c-fn> <nr-args> <infix-flag> <c-flag>)

+

+(define *reckless-s->c-fun-table*

+  (append

+

+   (if *badivsgns-flag*

+       '()

+       '((quotient "/" 2 #t #t)

+	 (remainder "%" 2 #t #t)

+	 (/  "/" 2 #t #t)))

+

+   (list

+    (list *sysapply* "apply" 3 #f #f)

+    (list *make-cclo* "makcclo" 2 #f #f)

+    (list *global-access* "GLOBAL" 1 #f #f)

+    (list *velts-function* "VELTS" 1 #f #f)

+    (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)

+    (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)

+    (list *not?*  "!" 1 #f #t)

+    (list *and?* "&&"    2 #t #t)

+    (list *or?*  "||"    2 #t #t)

+    (list *open-file-function* "open_file" 2 #f #f)

+    (list *set-current-input-port-function* "set_inp" 1 #f #f)

+    (list *set-current-output-port-function* "set_outp" 1 #f #f)

+    (list *num-s->c* "INUM" 1 #f #f)

+    (list *num-c->s* "MAKINUM" 1 #f #f)

+    (list *bool-s->c* "NFALSEP" 1 #f #f)

+    (list *bool-c->s* "SBOOL" 1 #f #f)

+    (list *char-c->s* "MAKICHR" 1 #f #f))

+

+   '((boolean? "BOOLEAN_P" 1 #f #t)

+     (symbol?  "SYMBOL_P"  1 #f #t)

+     (char?    "CHAR_P"    1 #f #t)

+     (vector?  "VECTOR_P"  1 #f #t)

+     (pair?    "PAIR_P"    1 #f #t)

+     (number?  "NUMBER_P"  1 #f #t)

+     (complex? "NUMBER_P" 1 #f #t)

+     (real?    "NUMBER_P"    1 #f #t)

+     (rational? "NUMBER_P" 1 #f #t)

+     (integer?  "INTEGER_P" 1 #f #t)

+     (string?  "STRING_P"  1 #f #t)

+     (procedure? "procedurep" 1 #f #t)

+

+     (not      "NOT"     1 #f #f)

+     (eq?      "=="       2 #t #t)

+     (eqv?     "=="       2 #t #t)

+     (char=?   "=="       2 #t #t)

+     (null?    "NULL_P"    1 #f #t)

+     (zero?    "ZERO_P"    1 #f #t)

+     (positive? "POSITIVE_P" 1 #f #t)

+     (negative? "NEGATIVE_P" 1 #f #t)

+

+     (logand "&" 2 #t #t)

+     (logior "|" 2 #t #t)

+     (logxor "^" 2 #t #t)

+     (lognot "~" 1 #f #t)

+     (logsleft  "<<" 2 #t #t)

+     (logsright ">>" 2 #t #t)

+

+     (=	"=="       2 #t #t)

+     (<	"<"	2 #t #t)

+     (>	">"	2 #t #t)

+     (<=       "<="       2 #t #t)

+     (>=       ">="       2 #t #t)

+

+     (+	"+"	2 #t #t)

+     (-	"-"	2 #t #t)

+     (*	"*"	2 #t #t)

+

+     (/	"lquotient"  2 #f #f)

+     (set-car! "SET_CAR"   2 #f #t)

+     (set-cdr! "SET_CDR"   2 #f #t)

+     (vector-set! "VECTOR_SET" 3 #f #t)

+     (vector-ref  "VECTOR_REF" 2 #f #t)

+

+     (equal? "equal" 2))

+

+   *standard-s->c-fun-table*))

+

+(define *floats-s->c-fun-table*

+  (append

+

+   (list

+    (list *sysapply* "apply" 3 #f #f)

+    (list *make-cclo* "makcclo" 2 #f #f)

+    (list *global-access* "GLOBAL" 1 #f #f)

+    (list *velts-function* "VELTS" 1 #f #f)

+    (list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)

+    (list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)

+    (list *not?*  "!" 1 #f #t)

+    (list *and?* "&&"    2 #t #t)

+    (list *or?*  "||"    2 #t #t)

+    (list *open-file-function* "open_file" 2 #f #f)

+    (list *set-current-input-port-function* "set_inp" 1 #f #f)

+    (list *set-current-output-port-function* "set_outp" 1 #f #f)

+    (list *num-s->c* "INUM" 1 #f #f)

+    (list *num-c->s* "MAKINUM" 1 #f #f)

+    (list *bool-s->c* "NFALSEP" 1 #f #f)

+    (list *bool-c->s* "SBOOL" 1 #f #f)

+    (list *char-c->s* "MAKICHR" 1 #f #f))

+

+   '((boolean? "BOOLEAN_P" 1 #f #t)

+     (symbol?  "SYMBOL_P"  1 #f #t)

+     (char?    "CHAR_P"    1 #f #t)

+     (vector?  "VECTOR_P"  1 #f #t)

+     (pair?    "PAIR_P"    1 #f #t)

+     (number?  "NUMBERP"  1 #f #t) ;;; diff from the int case; scm.h macro

+     (complex? "NUMBERP" 1 #f #t) ;;; not in the int case; scm.h macro

+     (real?    "realp"    1 #f #t) ;;; not in the int case;

+     (rational? "realp" 1 #f #t) ;;; not for int; ONLY for FLOATS

+     (integer?  "intp" 1 #f #t) ;;; not for int; ONLY for FLOATS

+     (string?  "STRING_P"  1 #f #t)

+     (procedure? "procedurep" 1 #f #t)

+

+     (not      "NOT"     1 #f #f)

+     (eq?      "=="       2 #t #t)

+     (eqv?     "eqv"       2 #f #t);; diff for int

+     (char=?   "=="       2 #t #t)

+     (null?    "NULL_P"    1 #f #t)

+     (zero?    "zerop"    1 #f #t);; diff for int

+     (positive? "positivep" 1 #f #t);; diff for int

+     (negative? "negativep" 1 #f #t);; diff for int

+

+     (logand "&" 2 #t #t)

+     (logior "|" 2 #t #t)

+     (logxor "^" 2 #t #t)

+     (lognot "~" 1 #f #t)

+     (logsleft  "<<" 2 #t #t)

+     (logsright ">>" 2 #t #t)

+

+     (=	"eqp"       2 #f #t);; diff for int

+     (<	"lessp"     2 #f #t);; diff for int

+     (>	"greaterp"  2 #f #t);; diff for int

+     (<=       "leqp"      2 #f #t);; diff for int

+     (>=       "greqp"     2 #f #t);; diff for int

+

+     (+	"sum"	2 #f #t);; diff for int

+     (-	"difference" 2 #f #t);; diff for int

+     (*	"product"    2 #f #t);; diff for int

+

+     (/	"divide"    2 #f #f);; diff for int

+     (quotient "lquotient" 2 #f #f)

+     (remainder "lremainder" 2 #f #f)

+

+     (set-car! "SET_CAR"   2 #f #t)

+     (set-cdr! "SET_CDR"   2 #f #t)

+     (vector-set! "VECTOR_SET" 3 #f #t)

+     (vector-ref  "VECTOR_REF" 2 #f #t)

+

+     (equal? "equal" 2))

+

+   *standard-s->c-fun-table*))

+

+

+(define (primitive? fn)

+  (or (member fn *cxr-funs*)

+      (if *floats-flag*

+	  (assq fn *floats-s->c-fun-table*)

+	  (assq fn *reckless-s->c-fun-table*))

+      (assq fn *switch-args-table*)

+      (assq fn *add-args-table*)

+      (member fn '(list append cond case do let let* letrec define

+			if and or map for-each))))

+

+(define (fixed-arity-primitive? fn)

+  (or (member fn *cxr-funs*)

+      (and (if *floats-flag*

+	       (assq fn *floats-s->c-fun-table*)

+	       (assq fn *reckless-s->c-fun-table*))

+	   (not (assq fn *associative-fun-table*))

+	   (not (assq fn *comparison-fun-table*))

+	   (not (assq fn *add-args-table*))

+	   (not (member fn '(list append cond case do let let* letrec

+				  define if and or map for-each

+				  < > <= = >= + * - /

+				  %< %> %<= %= %>= %+ %* %- %/ ))))

+      (assq fn *switch-args-table*)))

+

+(define (primitive-arity fn)

+  (let ((tmp (if *floats-flag*

+		 (assq fn *floats-s->c-fun-table*)

+		 (assq fn *reckless-s->c-fun-table*))))

+    (cond (tmp (caddr tmp))

+	  ((memq fn *cxr-funs*) 1)

+	  (else #f))))

+

+;===================================================================

+;

+;		   introducing type conversion,

+;		     collecting constants,

+;		  moving variables to top-let.

+;

+;===================================================================

+

+

+(define (type-const-wholedef term)

+  (set! *local-vars* '())

+  (set! *local-parameters*

+	(map (lambda (x) (if (pair? x) (cadr x) x))

+	     (cadr (caddr term))))

+  (set! *current-fun-name* (cadr term))

+  (let* ((tmp (map type-const-pass (cddr (caddr term))))

+	 (tmp2 (list 'lambda

+		     (cadr (caddr term))

+		     (cons 'let*

+			   (cons (map (lambda (x) (list x *dummy*))

+				      *local-vars*)

+				 (begins->list tmp))))))

+    (list (car term) (cadr term) tmp2)))

+

+

+

+(define (begins->list lst)

+  (let ((res '()))

+    (do ((part lst (cdr part)))

+	((null? part))

+      (if (and (pair? (car part))

+	       (or (eq? 'begin (caar part))

+		   (eq? *op-begin* (caar part))))

+	  (set! res (append (reverse (begins->list (cdar part))) res))

+	  (set! res (cons (car part) res))))

+    (reverse res)))

+

+

+(define (type-const-pass-res term)

+  (cond

+   ((string? term)

+    (make-string-constant term))

+   ((char? term)

+    (list *char-c->s* term))

+   ((vector? term)

+    (make-vector-constant term))

+   ((number? term)

+    (if (and (integer? term)

+	     (exact? term)

+	     (<= term most-positive-fixnum)

+	     (>= term most-negative-fixnum))

+	(list *num-c->s* term)

+	(begin

+	  (if (not *floats-flag*)

+	      (report-warning

+	       "exact arithmetic assumed but a nonexact number encountered: " term))

+	  (make-number-constant term))))

+   ((symbol? term)

+    (cond ((or (memq term *local-parameters*)

+	       (memq term *local-vars*)

+	       (memq term *special-c-vars*)

+	       (memq term *special-scm->c-functions*))

+	   term)

+	  ((memq term *fast-vars-list*)

+	   term)

+	  ((memq term *interpreter-defined-vars*)

+	   (list *global-access* term))

+	  ((memq term *global-vars-list*)

+	   (list *global-access* term))

+	  ((or (member-if (lambda (x) (eq? term (cadr x)))

+			  *new-constant-list*)

+	       (member-if (lambda (x) (eq? term (cadr x)))

+			  *symbol-constant-table*)

+	       (in-file-defined? term))

+	   term)

+	  (else (or (memq term *unknown-vars*)

+		    (set! *unknown-vars* (cons term *unknown-vars*)))

+		(list *global-access* (make-unknown-constant term)))))

+   ((boolean? term)

+    (list *bool-c->s* term))

+   ((null? term)

+    '())

+   ((not (pair? term))

+    (report-error "disallowed object: " term))

+   ((eq? *special-pseudoquote* (car term))

+    term)

+   ((eq? *actual-c-string* (car term))

+    term)

+   ((eq? *actual-c-int* (car term))

+    term)

+   ((eq? *actual-c-eval* (car term))

+    term)

+   ((eq? 'quote (car term))

+    (cond ((or (string? (cadr term))

+	       (vector? (cadr term))

+	       (number? (cadr term))

+	       (boolean? (cadr term))

+	       (char? (cadr term))

+	       (null? (cadr term)))

+	   (type-const-pass (cadr term)))

+	  ((symbol? (cadr term))

+	   (make-symbol-constant (cadr term)))

+	  ((pair? (cadr term))

+	   (make-pair-constant (cadr term)))

+	  (else

+	   (report-error "disallowed object: " term))))

+   ((and

+     *reckless-arithmetic-flag*

+     (not (modified-fun? (car term)))

+     (or (memq (car term) *always-num-arg-c-funs*)

+	 (and (not *floats-flag*)

+	      (memq (car term) *num-arg-c-funs*))))

+    (let* ((tmp (map type-const-pass (cdr term)))

+	   (tmp2

+	    (cons (car term)

+		  (map (lambda (x)

+			 (if (and (pair? x)

+				  (eq? (car x) *num-c->s*))

+			     (cadr x)

+			     (list *num-s->c* x)))

+		       tmp))))

+      (cond ((memq (car term) *num-res-c-funs*)

+	     (list *num-c->s* tmp2))

+	    ((memq (car term) '(= < <= > >= %= %< %<= %> %>=))

+	     (cond

+	      ((and (pair? (cadr tmp2))

+		    (pair? (caddr tmp2))

+		    (eq? (car (cadr tmp2)) (car (caddr tmp2)))

+		    (eq? *num-s->c* (car (cadr tmp2))))

+	       (list *bool-c->s*

+		     (cons (car term) (map cadr (cdr tmp2)))))

+	      ((or (and (not (pair? (cadr tmp2)))

+			(pair? (caddr tmp2)))

+		   (and (not (pair? (caddr tmp2)))

+			(pair? (cadr tmp2))))

+	       (list *bool-c->s* (cons (car term) tmp)))

+	      (else

+	       (list *bool-c->s* tmp2))))

+	    ((and (not *floats-flag*)

+		  (memq (car term) *bool-res-c-funs*))

+	     (list *bool-c->s* tmp2))

+	    ((memq (car term) *always-bool-res-c-funs*)

+	     (list *bool-c->s* tmp2))

+	    (else

+	     tmp2))))

+   ((and (or (memq (car term) '(eq? char=? %eqv? %=))

+	     (and (not *floats-flag*)

+		  (or (eq? 'eqv? (car term))

+		      (eq? '= (car term)))))

+	 (not (modified-fun? (car term))))

+    (let ((tmp (map type-const-pass (cdr term))))

+      (if (and (pair? (car tmp))

+	       (memq (caar tmp) *type-converters*)

+	       (pair? (cadr tmp))

+	       (memq (caadr tmp) *type-converters*))

+	  (list *bool-c->s* (cons (car term) (map cadr tmp)))

+	  (list *bool-c->s* (cons (car term) tmp)))))

+   ((and (memq (car term) *bool-arg-c-funs*)

+	 (not (modified-fun? (car term))))

+    (let* ((tmp (map type-const-pass (cdr term)))

+	   (tmp2 (cons (car term) (map c-boolify tmp))))

+      (if (memq (car term) *bool-res-c-funs*)

+	  (list *bool-c->s* tmp2)

+	  tmp2)))

+   ((and (not *floats-flag*)

+	 (memq (car term) *bool-res-c-funs*)

+	 (not (modified-fun? (car term))))

+    (list *bool-c->s*

+	  (cons (car term) (map type-const-pass (cdr term)))))

+   ((and (memq (car term) *always-bool-res-c-funs*)

+	 (not (modified-fun? (car term))))

+    (list *bool-c->s*

+	  (cons (car term) (map type-const-pass (cdr term)))))

+   ((or (eq? 'if (car term)) (eq? *op-if* (car term)))

+    (let ((tmp (map type-const-pass (cdr term))))

+      (cons (car term)

+	    (cons (c-boolify (car tmp)) (cdr tmp)))))

+   ((eq? (car term) 'let*)

+    (set! *local-vars* (union (map car (cadr term)) *local-vars*))

+    (cons 'begin

+	  (map type-const-pass

+	       (begins->list

+		(append (map (lambda (x) (cons 'set! x)) (cadr term))

+			(cddr term))))))

+   ((eq? (car term) *op-let*)

+    (set! *local-vars* (union (map car (cadr term)) *local-vars*))

+    (cons *op-begin*

+	  (map type-const-pass

+	       (begins->list

+		(append (map (lambda (x) (cons 'set! x)) (cadr term))

+			(cddr term))))))

+   ((or (eq? 'begin (car term)) (eq? *op-begin* (car term)))

+    (cons (car term)

+	  (begins->list (map type-const-pass (cdr term)))))

+   ((eq? (car term) 'do)

+    (set! *local-vars* (union (map car (cadr term)) *local-vars*))

+    (let ((tmp (list* 'do

+		      (map (lambda (x) (map type-const-pass x))

+			   (cadr term))

+		      (map type-const-pass (caddr term))

+		      (map type-const-pass (cdddr term)))))

+      (if (null? (cdr (caddr tmp)))

+	  (cons *do-not*

+		(begins->list

+		 (cons (cadr tmp)

+		       (cons (cons (c-negate

+				    (c-boolify

+				     (car (caddr tmp))))

+				   (cdr (caddr tmp)))

+			     (cdddr tmp)))))

+	  (cons

+	   'begin

+	   (begins->list

+	    (cons

+	     (cons *do-not*

+		   (begins->list

+		    (cons (cadr tmp)

+			  (cons (list

+				 (c-negate

+				  (c-boolify

+				   (car (caddr tmp)))))

+				(cdddr tmp)))))

+	     (begins->list (cdr (caddr tmp)))))))))

+   ((eq? *function* (car term))

+    (cond ((or (memq (cadr term) *local-vars*)

+	       (memq (cadr term) *local-parameters*))

+	   (list *function* (cadr term)))

+	  ((memq (cadr term) *top-level-funs*)

+					;  (report-error

+					;    "In " *current-fun-name* " compiled function "

+					;    (cadr term) " occurs as an argument. Use lambdaterm!")

+	   (list *function* (cadr term)))

+	  ((in-file-defined? (cadr term))

+	   (list *function* (cadr term)))

+	  (else

+	   (report-error

+	    "In " *current-fun-name* " interpreted function "

+	    (cadr term) " occurs as an argument. Use lambdaterm!"))))

+   ((and (memq (car term)  *cxr-funs*)

+	 (not (modified-fun? (car term))))

+    (cxr-open (car term) (type-const-pass (cadr term))))

+					; the following always fails

+   ((begin (set! term (fun-names-to-refs term)) #f))

+   ((unknown-function? (car term) (cdr term))

+    (make-unknown-call term))

+   ((and (eq? (car term) 'vector-set!)

+	 (memq (cadr term) *stable-vector-names*))

+    (cons *st-vector-set*

+	  (cons (string->symbol

+		 (string-append

+		  (symbol->string (cadr term))

+		  *st-vector-postfix*))

+		(map type-const-pass (cddr term)))))

+   ((and (eq? (car term) 'vector-ref)

+	 (memq (cadr term) *stable-vector-names*))

+    (cons *st-vector-ref*

+	  (cons (string->symbol

+		 (string-append

+		  (symbol->string (cadr term))

+		  *st-vector-postfix*))

+		(map type-const-pass (cddr term)))))

+   (else

+    (cons (car term)

+	  (map type-const-pass (cdr term))))))

+

+(define (type-const-pass term)

+  (define res (type-const-pass-res term))

+  (if (and (pair? res) (or (eq? 'begin (car res))

+			   (eq? *op-begin* (car res))))

+      (cons (car res) (begins->list (cdr res)))

+      res))

+

+

+(define (fun-names-to-refs term)

+  (let ((hofdata (assq (car term) *liftable-hof-database*))

+	(tmp '()))

+    (if hofdata

+	(cons (car term)

+	      (map (lambda (flag arg)

+		     (cond

+		      ((not (symbol? arg)) arg)

+		      (flag arg)

+		      (else (fun-names-to-refs-aux arg))))

+		   (cdr hofdata)

+		   (cdr term)))

+	(cons (car term)

+	      (map (lambda (arg)

+		     (if (symbol? arg)

+			 (fun-names-to-refs-aux arg)

+			 arg))

+		   (cdr term))))))

+

+(define (fun-names-to-refs-aux name)

+  (if (and (not (memq name *local-parameters*))

+	   (not	(memq name *local-vars*))

+	   (in-file-defined? name))

+      (let ((newname (make-closure-scmobj-name name)))

+	(if (not (memq name *symbol-and-fun-list*))

+	    (begin

+	      (set! *var-make-list*

+		    (cons `(set!

+			    ,(make-closure-scmobj-name name)

+			    (,*c-adr* (cdr (,*intern-function*

+					    (,*actual-c-string*

+					     ,(symbol->string name))

+					    ,(string-length

+					      (symbol->string name))))))

+			  *var-make-list*))

+	      (set! *symbol-and-fun-list* (cons name *symbol-and-fun-list*))))

+	(list *global-access* newname))

+      name))

+

+

+(define (unknown-function? fn args)

+  (let ((len (length args)))

+    (or

+     (pair? fn)

+     (modified-fun? fn)

+     (not

+      (or (let ((tmp (memq fn *prohibited-funs*)))

+	    (if tmp

+		(report-error "In " *current-fun-name*

+			      " a prohibited function "

+			      fn " is called."))

+	    #f)

+	  (eq? fn *current-fun-name*)

+	  (memq fn *special-scm->c-functions*)

+	  (assq fn *switch-args-table*)

+	  (assq fn *add-args-table*)

+	  (memq fn '(vector string if begin let* lambda set!))

+	  (memq fn *internal-c-functions*)

+	  (let ((tmp (if *floats-flag*

+			 (assq fn *floats-s->c-fun-table*)

+			 (assq fn *reckless-s->c-fun-table*))))

+	    (if (and tmp (not (eqv? len (caddr tmp))))

+		(report-error "In " *current-fun-name* " function "

+			      fn " is called with a wrong nr of args."))

+	    tmp)

+	  (let ((tmp (member-if (lambda (x) (eq? fn (cadr x)))

+				*to-do-fun-list*)))

+	    (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))

+		(if (memq fn *top-level-funs*)

+		    (report-error "In " *current-fun-name* " function "

+				  fn " is called with a wrong nr of args.")

+		    (report-error "In " *current-fun-name* " function "

+				  fn

+				  " is called with a wrong nr of args or builds closures.")))

+	    tmp)

+	  (let ((tmp (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))

+	    (if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))

+		(if (memq fn *top-level-funs*)

+		    (report-error "In " *current-fun-name* " function "

+				  fn " is called with a wrong nr of args.")

+		    (report-error "In " *current-fun-name* " function "

+				  fn

+				  " is called with a wrong nr of args or builds closures.")))

+	    tmp)

+	  (memq fn *top-level-funs*))))))

+

+

+(define (in-file-defined? fn)

+  (or (memq fn *top-level-funs*)

+      (eq? fn *current-fun-name*)

+      (member-if (lambda (x) (eq? fn (cadr x))) *to-do-fun-list*)

+      (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))

+

+(define (top-nonlist-in-file-defined? fn)

+  (let ((x (or (member-if

+		(lambda (x) (or (eq? fn (cadr x))

+				(and (pair? (cadr x)) (eq? fn (caadr x)))))

+		*to-do-fun-list*)

+	       (member-if

+		(lambda (x) (or (eq? fn (cadr x))

+				(and (pair? (cadr x)) (eq? fn (caadr x)))))

+		*passed-defs*))))

+    (and x

+	 (let ((y (car x)))

+	   (if (pair? (cadr y))

+	       (list? (cadr y))

+	       (and (pair? (cddr y))

+		    (pair? (caddr y))

+		    (eq? 'lambda (car (caddr y)))

+		    (pair? (cdr (caddr y)))

+		    (list? (cadr (caddr y)))))))))

+

+(define (make-unknown-call term)

+  (let* ((fn (car term))

+	 (args1 (map type-const-pass (cdr term)))

+	 (args (map make-interpreter-usable args1))

+	 (glob '()))

+    (if (pair? fn)

+	(set! glob (type-const-pass (car term)))

+	(if (or (memq fn *special-c-vars*)

+		(memq fn *local-parameters*)

+		(memq fn *local-vars*))

+	    (set! glob fn)

+	    (set! glob (list *global-access* (make-unknown-constant fn)))))

+    (or (pair? fn)

+	(memq fn *special-c-vars*)

+	(memq fn *local-parameters*)

+	(memq fn *local-vars*)

+	(memq fn *unknown-functions*)

+	(set! *unknown-functions* (cons fn *unknown-functions*)))

+    (list *sysapply*

+	  glob

+	  (if (null? args) '() (car args))

+	  (if (null? args)

+	      '()

+	      (make-apply-second-arg (cdr args))))))

+

+(define (make-unknown-call-aux term args)

+  (let ((fn (caar term)))

+    (if (or (in-file-defined? fn)

+	    (memq fn *prohibited-funs*))

+	(report-error "In " *current-fun-name* " function "

+		      fn " is assumed to return a closure.")

+	(make-unknown-call (car term)))))

+

+

+(define (make-interpreter-usable term)

+  (let ((fn (if (pair? term)

+		(if (and (eq? *global-access* (car term))

+			 (in-file-defined? (cadr term)))

+		    (cadr term)

+		    #f)

+		(if (and (symbol? term)

+			 (in-file-defined? term))

+		    term

+		    #f)))

+	(tmp '()))

+    (if (not fn)

+	term

+	(make-interpreter-funname fn))))

+

+

+(define (make-interpreter-funname fn)

+  (let ((tmp (assq fn *interpreter-funname-table*)))

+    (if tmp

+	(cdr tmp)

+	(begin

+	  (set! tmp

+		(string->symbol

+		 (string-append (symbol->string fn) *interpreter-suffix*)))

+	  (set! *interpreter-funname-table*

+		(cons (cons fn tmp) *interpreter-funname-table*))

+	  (list *global-access* tmp)))))

+

+(define (make-unknown-constant var)

+  (if (memq var *global-vars-list*)

+      var

+      (begin

+	(set! *global-vars-list* (cons var *global-vars-list*))

+	(set! *var-make-list*

+	      (cons `(set!

+		      ,var

+		      (,*c-adr* (cdr (,*intern-function*

+				      (,*actual-c-string*

+				       ,(symbol->string var))

+				      ,(string-length

+					(symbol->string var))))))

+		    *var-make-list*))

+	var)))

+

+(define (make-apply-second-arg args)

+  (if (null? args)

+      *listofnull*

+      (list 'cons

+	    (car args)

+	    (make-apply-second-arg (cdr args)))))

+

+

+

+(define (make-string-constant str)

+  (let ((name (make-constant-name)))

+    (set! *new-constant-list*

+	  (cons (list 'set!

+		      name

+		      (list 'scm-gc-protect

+			    (list *makfromstr-function*

+				  (list *actual-c-string* str)

+				  (string-length str))))

+		*new-constant-list*))

+    name))

+

+(define (make-number-constant num)

+  (let ((name (make-constant-name))

+	(str (number->string num)))

+    (set! *new-constant-list*

+	  (cons (list 'set!

+		      name

+		      (list 'scm-gc-protect

+			    (list *string->number-function*

+				  (list *makfromstr-function*

+					(list *actual-c-string* str)

+					(string-length str))

+				  (list *num-c->s* 10))))

+		*new-constant-list*))

+    name))

+

+

+(define (make-vector-constant vect)

+  (let* ((name (make-constant-name))

+	 (tmp (list 'set!

+		    name

+		    (list 'scm-gc-protect

+			  (list 'list->vector

+				(make-pair-constant-aux

+				 (vector->list vect)))))))

+    (set! *new-constant-list* (cons tmp *new-constant-list*))

+    name))

+

+

+(define (make-pair-constant pair)

+  (let* ((name (make-constant-name))

+	 (tmp (list 'set!

+		    name

+		    (list 'scm-gc-protect

+			  (list 'cons

+				(make-pair-constant-aux (car pair))

+				(make-pair-constant-aux (cdr pair)))))))

+    (set! *new-constant-list* (cons tmp *new-constant-list*))

+    name))

+

+(define (make-pair-constant-aux term)

+  (if (pair? term)

+      (list 'cons

+	    (make-pair-constant-aux (car term))

+	    (make-pair-constant-aux (cdr term)))

+      (type-const-pass (list 'quote term))))

+

+(define (make-symbol-constant symb)

+  (let ((tmp (assq symb *symbol-constant-table*)))

+    (if tmp

+	(cadr tmp)

+	(let ((name (make-symbol-name symb))

+	      (str (symbol->string symb))

+	      (clname '()))

+	  ;; if the symb is also a top-level-fun, then avoid

+	  ;; applying make_subr to the symbol name string:

+	  ;; this would mess up symbol-names table for scm.

+	  (if (and (memq symb *top-level-funs*)

+		   (not (memq symb *symbol-and-fun-list*)))

+	      (begin

+		(set! *var-make-list*

+		      (cons `(set!

+			      ,(make-closure-scmobj-name symb)

+			      (,*c-adr* (cdr (,*intern-function*

+					      (,*actual-c-string*

+					       ,(symbol->string symb))

+					      ,(string-length

+						(symbol->string symb))))))

+			    *var-make-list*))

+

+		(set! *symbol-and-fun-list*

+		      (cons symb *symbol-and-fun-list*))))

+	  (set! *symbol-constant-table*

+		(cons (list symb name) *symbol-constant-table*))

+	  (set! *symbol-list*

+		(cons (list 'set!

+			    name

+			    `(scm-gc-protect

+			      (car (,*intern-symbol-function*

+				    (,*actual-c-string* ,str)

+				    ,(string-length str)))))

+			;;;    (list 'string->symbol

+			;;;	  (list 'list->string

+			;;;		(make-pair-constant-aux

+			;;;		   (string->list

+			;;;		      (symbol->string symb)))))

+		      *symbol-list*))

+	  name))))

+

+(define (make-constant-name)

+  (set! *new-constant-num* (+ 1 *new-constant-num*))

+  (string->symbol (string-append *new-constant-prefix*

+				 (number->string *new-constant-num*))))

+

+

+(define (make-symbol-name symb)

+  (string->symbol (string-append (symbol->string symb)

+				 *symbol-name-postfix*)))

+

+(define (c-negate term)

+  (if (and (pair? term) (eq? *not?* (car term)))

+      (cadr term)

+      (list *not?* term)))

+

+(define (cxr-open cxr arg)

+  (let* ((str (symbol->string cxr))

+	 (chr #\c)

+	 (len (string-length str))

+	 (res arg))

+    (do ((n (- len 2) (- n 1)))

+	((= 0 n))

+      (set! chr (string-ref str n))

+      (set! res

+	    (list (if (eqv? #\a chr) 'car 'cdr) res)))

+    res))

+

+

+(define (c-boolify term)

+  (if (and (pair? term) (eq? *bool-c->s* (car term)))

+      (cadr term)

+      (list *bool-s->c* term)))

+

+;===================================================================

+;

+;			  a pass for

+;	    correcting higher-order function calls and

+;		 dotted-arglist function calls.

+;

+;===================================================================

+

+

+(define (ho-dot-wholedef term)

+  (set! *current-fun-name* (cadr term))

+  (ho-dot-pass term))

+

+(define (ho-dot-pass term)

+  (cond ((or (not (pair? term)) (eq? 'quote (car term)))

+	 term)

+	((memq (car term) *dot-arg-funs*)

+	 (let* ((template (assq (car term) *dot-arg-templates*))

+		(new  (make-listarg-arglist (cadr template) (cdr term))))

+	   (if (and (memq (car term) *higher-order-funs*)

+		    (liftable-hofname? (car term)))

+	       (correct-ho-call

+		(cons (car term) (map ho-dot-pass new)))

+	       (cons (car term) (map ho-dot-pass new)))))

+	((and (memq (car term) *higher-order-funs*)

+	      (liftable-hofname? (car term)))

+	 (correct-ho-call (map ho-dot-pass term)))

+	(else

+	 (map ho-dot-pass term))))

+

+(define (correct-ho-call term)

+  (let* ((add-args '())

+	 (stay-args '())

+	 (name (car term))

+	 (data (assq name *higher-order-templates*))

+	 (new-template '()))

+

+    (do ((args (cdr term) (cdr args))

+	 (funtemplate (cadr data) (cdr funtemplate)))

+	((null? args))

+      (if (car funtemplate)

+	  (begin

+	    (if (and (not (pair? (car args)))

+		     (and (primitive? (car args))

+			  (if (fixed-arity-primitive? (car args))

+			      #t

+			      (report-error

+			       "in function " *current-fun-name*

+			       " a variable-arity primitive is passed to a higher-order fun: " term))))

+		(let*

+		    ((tmpargs (reverse

+			       (list-tail '(w v u z y x)

+					  (- 6 (primitive-arity (car args))))))

+		     (newfun

+		      (list 'lambda

+			    tmpargs

+			    (cons (car args) tmpargs)))

+		     (newname (make-new-primitive-instname (car args))))

+		  (set! *to-do-fun-list*

+			(cons (list 'define newname newfun)

+			      *to-do-fun-list*))

+		  (set! args (cons newname (cdr args)))))

+	    (if (pair? (car args))

+		(begin

+		  (set! add-args

+			(append (reverse (cdar args)) add-args))

+		  (set! stay-args

+			(cons (caar args) stay-args))

+		  (set! new-template

+			(cons (list

+			       (length

+				(filter (lambda (x)

+					  (or (not (pair? x))

+					      (not (eq? *c-adr* (car x)))))

+					(cdar args)))

+			       (length

+				(filter (lambda (x)

+					  (and (pair? x)

+					       (eq? *c-adr* (car x))))

+					(cdar args))))

+			      new-template)))

+		(begin

+		  (set! new-template (cons (list '0 '0) new-template))

+		  (set! stay-args (cons (car args) stay-args)))))

+	  (begin

+	    (set! new-template (cons '0 new-template))

+	    (set! stay-args (cons (car args) stay-args)))))

+

+    (set! new-template (reverse new-template))

+    (set! add-args (reverse add-args))

+    (set! stay-args (reverse stay-args))

+    (let ((attempt (assoc new-template (cddr data))))

+      (if attempt

+	  (begin

+	    (cons (cadr attempt)

+		  (append add-args

+			  (map (lambda (x y)

+				 (if x (list *function* y) y))

+			       (cadr data)

+			       stay-args))))

+	  (begin

+	    (make-new-ho-instance term new-template data add-args stay-args)

+	    (let ((attempt2 (assoc new-template (cddr data))))

+	      (cons (cadr attempt2)

+		    (append add-args

+			    (map (lambda (x y)

+				   (if x (list *function* y) y))

+				 (cadr data)

+				 stay-args)))))))))

+

+

+(define (make-new-ho-instance term new-template data add-args stay-args)

+  (let* ((done-mainfun-flag #f)

+	 (mainfun-place (member-if (lambda (x) (eq? (cadr x) (car term)))

+				   *to-do-fun-list*))

+	 (ho-fun  (if mainfun-place

+		      (begin

+			(set! done-mainfun-flag #f)

+			(car mainfun-place))

+		      (begin

+			(set! mainfun-place

+			      (member-if (lambda (x) (eq? (cadr x) (car term)))

+					 *passed-defs*))

+			(if (not mainfun-place)

+			    (report-error "Higher-order function "

+					  (car term)

+					  " is not defined."))

+			(set! done-mainfun-flag #t)

+			(car mainfun-place))))

+	 (dot-data (assq (cadr ho-fun) *dot-arg-templates*))

+	 (data (assq (car term) *higher-order-templates*))

+	 (ho-term (caddr ho-fun))

+	 (new-args '())

+	 (new-name (make-new-instname (cadr ho-fun) (length (cddr data)))))

+    (set! *top-level-funs*

+	  (cons new-name *top-level-funs*))

+    (set! *make-new-ho-data* '())

+    (for-each (lambda (x y)

+		(if (pair? x)

+		    (let ((new (make-new-parameters x)))

+		      (set! *make-new-ho-data*

+			    (cons (cons (if (pair? y) (cadr y) y)

+					(args->list new))

+				  *make-new-ho-data*))

+		      (set! new-args

+			    (append new new-args)))))

+	      new-template

+	      (args->list (cadr ho-term)))

+    (if dot-data

+	(begin (set! *dot-arg-funs* (cons new-name *dot-arg-funs*))

+	       (set! *dot-arg-templates*

+		     (cons (list new-name

+				 (append new-args (cadr dot-data)))

+			   *dot-arg-templates*))))

+    (set! ho-term (make-new-inst-aux

+		   ho-term (args->list new-args) (cadr ho-fun) new-name))

+    (set! ho-term

+	  (cons (car ho-term)

+		(cons (append new-args (cadr ho-term))

+		      (cddr ho-term))))

+    (set! ho-fun

+	  (list (car ho-fun) new-name ho-term))

+    (set-cdr! (my-last-pair data)

+	      (list (list new-template (cadr ho-fun))))

+    (if done-mainfun-flag

+	(begin

+	  (set-cdr! mainfun-place

+		    (cons (car mainfun-place) (cdr mainfun-place)))

+	  (set-car! mainfun-place ho-fun))

+	(begin

+	  (set-cdr! mainfun-place

+		    (cons ho-fun (cdr mainfun-place)))))))

+

+(define (make-new-instname genname nr)

+  (let ((name

+	 (string->symbol

+	  (string-append (symbol->string genname)

+			 *new-instfun-infix*

+			 (number->string nr)))))

+    name))

+

+(define (make-new-primitive-instname genname)

+  (set! *new-primitive-instnr* (+ 1 *new-primitive-instnr*))

+  (let ((name

+	 (string->symbol

+	  (string-append (symbol->string genname)

+			 *new-instfun-infix*

+			 (number->string *new-primitive-instnr*)))))

+    name))

+

+(define (make-new-inst-aux term n-args o-name n-name)

+  (let ((tmp #f))

+    (cond ((or (not (pair? term)) (eq? 'quote (car term))) term)

+	  ((eq? *higher-order-call* (car term))

+	   (set! tmp (assq (cadr term) *make-new-ho-data*))

+	   (if tmp

+	       (cons (car term)

+		     (cons (cadr term)

+			   (if (null? (cdr tmp))

+			       (cddr term)

+			       (append (cdr tmp) (cddr term)))))

+	       (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))

+		    term)))

+	  ((eq? (car term) 'lambda)

+	   (cons (car term)

+		 (cons (cadr term)

+		       (map (lambda (x)

+			      (make-new-inst-aux x n-args o-name n-name))

+			    (cddr term)))))

+	  ((eq? (car term) o-name)

+	   (cons n-name

+		 (append

+		  n-args

+		  (map (lambda (x)

+			 (make-new-inst-aux x n-args o-name n-name))

+		       (cdr term)))))

+	  (else

+	   (map (lambda (x) (make-new-inst-aux x n-args o-name n-name))

+		term)))))

+

+

+(define (make-new-parameters nums)

+  (let* ((vars1 '())

+	 (vars2 '()))

+    (do ((n (car nums) (- n 1)))

+	((zero? n))

+      (set! vars1 (cons (make-new-parameter) vars1)))

+    (do ((n (cadr nums) (- n 1)))

+	((zero? n))

+      (set! vars2 (cons (list *c-adr* (make-new-parameter)) vars2)))

+    (set! vars1 (reverse vars1))

+    (set! vars2 (reverse vars2))

+    (append vars1 vars2)))

+

+(define (make-new-parameter)

+  (set! *new-parameter-nr* (+ 1 *new-parameter-nr*))

+  (string->symbol (string-append *new-parameter-prefix*

+				 (number->string *new-parameter-nr*))))

+

+

+

+;===================================================================

+;

+;	      statement-lifting  & tail-recursion

+;

+;===================================================================

+

+

+(define (lift-statements-wholedef defterm)

+  (set! *current-fun-name* (cadr defterm))

+  (set! *tailrec-flag* #f)

+  (set! *higher-order-flag* #f)

+  (let ((res '())

+	(res2 '())

+	(newname #f)

+	(tmp '())

+	(lambdaterm (caddr defterm)))

+    (set! *higher-order-args* (args->list (cadr lambdaterm)))

+    (set! *current-formal-args* (cadr lambdaterm))

+    (set! *current-formal-argslist* (args->list (cadr lambdaterm)))

+    (set! res (lift-statements lambdaterm '()))

+    (if (not (list? (cadr lambdaterm)))

+	(begin

+	  (set! *dot-arg-funs*

+		(cons (cadr defterm) *dot-arg-funs*))

+	  (set! *dot-arg-templates*

+		(cons (list (cadr defterm)

+			    (cadr lambdaterm))

+		      *dot-arg-templates*))))

+    (if (and *higher-order-flag*

+	     (liftable-hofname? (cadr defterm)))

+	(begin

+	  (set! *higher-order-args*

+		(map (lambda (x) (if (eq? x '#t) '#t '#f))

+		     *higher-order-args*))

+	  (set! *higher-order-funs*

+		(cons (cadr defterm) *higher-order-funs*))

+	  (set! *higher-order-templates*

+		(cons

+		 (list (cadr defterm)

+		       *higher-order-args*

+		       (list (map (lambda (x)

+				    (if x (list '0 '0) '0))

+				  *higher-order-args*)

+			     (cadr defterm)))

+		 *higher-order-templates*))

+	  (if (and (memq *current-fun-name* *top-level-funs*)

+		   (not (null? *export-functions*))

+		   (or (not (pair? *export-functions*))

+		       (memq *current-fun-name* *export-functions*)))

+	      (begin

+		(set! newname

+		      (string->symbol

+		       (string-append (symbol->string *current-fun-name*)

+				      *export-hof-postfix*)))

+		(set! *top-level-funs*

+		      (cons newname *top-level-funs*))

+		(set! *export-table*

+		      (cons (list *current-fun-name* newname)

+			    *export-table*))

+		(set! tmp (assq *current-fun-name* *dot-arg-templates*))

+		(if tmp

+		    (begin

+		      (set! *dot-arg-templates*

+			    (cons (list newname (cadr tmp))

+				  *dot-arg-templates*))

+		      (set! *dot-arg-funs*

+			    (cons newname *dot-arg-funs*))))

+		(set! res2

+		      (make-export-hof res))))

+	  (set! res (cons (car res)

+			  (cons (map (lambda (x y)

+				       (if x (list *function* y) y))

+				     *higher-order-args*

+				     (maklist (cadr res)))

+				(cddr res))))))

+    (if *tailrec-flag*

+	(begin

+	  (set! res (cons (car res)

+			  (cons (cadr res)

+				(cons (list *mark-tailrec*)

+				      (cddr res)))))

+	  (if (not (null? res2))

+	      (set! res2 (cons (car res2)

+			       (cons (cadr res2)

+				     (cons (list *mark-tailrec*)

+					   (cddr res2))))))))

+    (set! res

+	  (list 'define (cadr defterm)

+		(if (list? (cadr res))

+		    res

+		    (cons (car res)

+			  (cons (maklist (cadr res))

+				(cddr res))))))

+    (if (null? res2)

+	(list res)

+	(list res

+	      (list 'define newname

+		    (if (list? (cadr res2))

+			res2

+			(cons (car res2)

+			      (cons (maklist (cadr res2))

+				    (cddr res2)))))))))

+

+

+(define (maklist args)

+  (cond ((symbol? args)

+	 (list args))

+	((null? args)

+	 '())

+	(else (cons (car args) (maklist (cdr args))))))

+

+

+(define (make-export-hof term)

+  (cond ((or (not (pair? term))

+	     (eq? 'quote (car term)))

+	 term)

+	((eq? 'lambda (car term))

+	 (cons (car term)

+	       (cons (cadr term)

+		     (map make-export-hof (cddr term)))))

+	((eq? (car term) *higher-order-call*)

+	 (list *sysapply*

+	       (cadr term)

+	       (if (null? (cddr term))

+		   '()

+		   (make-export-hof (caddr term)))

+	       (if (null? (cddr term))

+		   '()

+		   (make-apply-second-arg

+		    (make-export-hof (cdddr term))))))

+	((eq? (car term) *function*)

+	 (cadr term))

+	((eq? (car term) *current-fun-name*)

+	 (cons (string->symbol

+		(string-append (symbol->string *current-fun-name*)

+			       *export-hof-postfix*))

+	       (map make-export-hof (cdr term))))

+	(else

+	 (map make-export-hof term))))

+

+

+(define (lift-statements term checkvars)

+  (cond

+   ((or (not (pair? term)) (eq? 'quote (car term)))

+    term)

+   ((eq? 'lambda (car term))

+    (set! checkvars (args->list (cadr term)))

+    (append

+     (list 'lambda)

+     (list (cadr term))

+     (map (lambda (x) (lift-statements x checkvars))

+	  (butlast (cddr term) 1))

+     (list

+      (lift-statements

+       (push-result-var-in *return* (car (my-last-pair term)))

+       checkvars))))

+   ((and (eq? 'set! (car term))

+	 (or (null? (cdr term)) (null? (cddr term))))

+    (report-error

+     " scheme syntax in fun " *current-fun-name* ": " term))

+   ((and (eq? 'set! (car term))

+	 (pair? (caddr term))

+	 (memq (caaddr term) '(do if begin let*)))

+    (lift-statements (push-result-var-in (cadr term) (caddr term))

+		     checkvars))

+   ((eq? 'do (car term))

+    (set! checkvars (union (map car (cadr term)) checkvars))

+    (list* 'do

+	   (map

+	    (lambda (x)

+	      (map (lambda (y) (lift-stat-aux y checkvars)) x))

+	    (cadr term))

+	   (append (list

+		    (lift-stat-aux (car (caddr term)) checkvars))

+		   (map (lambda (x)

+			  (lift-statements x checkvars))

+			(cdr (caddr term))))

+	   (map (lambda (x) (lift-statements x checkvars))

+		(cdddr term))))

+   ((eq? 'if (car term))

+    (if (eq? 3 (length term))

+	(list 'if

+	      (lift-stat-aux (cadr term) checkvars)

+	      (lift-statements (caddr term) checkvars))

+	(list 'if

+	      (lift-stat-aux (cadr term) checkvars)

+	      (lift-statements (caddr term) checkvars)

+	      (lift-statements (cadddr term) checkvars))))

+   ((eq? 'begin (car term))

+    (append (list 'begin)

+	    (map (lambda (x)

+		   (lift-statements

+		    (if (and (pair? x) (eq? 'set! (car x)))

+			(push-result-var-in (cadr x) (caddr x))

+			x)

+		    checkvars))

+		 (cdr term))))

+   ((or (eq? 'let* (car term)) (eq? 'let (car term)))

+    (set! checkvars (union (map car (cadr term)) checkvars))

+    (append (list 'let*)

+	    (list (map (lambda (x) (list (car x) *dummy*)) (cadr term)))

+	    (map (lambda (x)

+		   (lift-statements

+		    (push-result-var-in (car x) (cadr x))

+		    checkvars))

+		 (cadr term))

+	    (map (lambda (x) (lift-statements x checkvars))

+		 (cddr term))))

+   ((and (eq? 'set! (car term))

+	 (pair? (caddr term))

+	 (memq (caaddr term) '(do if begin let*)))

+    (lift-statements (push-result-var-in (cadr term) (caddr term))

+		     checkvars))

+   (else

+    (lift-stat-aux term checkvars))))

+

+

+

+(define (lift-stat-aux term checkvars)

+  (cond

+   ((or (not (pair? term)) (eq? 'quote (car term)))

+    term)

+   ((eq? (car term) 'if)

+    (if (and *lift-ifs-flag*

+	     (or (lift-if-arg? (caddr term))

+		 (and (not (null? (cdddr term)))

+		      (lift-if-arg? (cadddr term)))))

+	(let ((argvars (free-vars term checkvars '()))

+	      (newname (new-fun-name *current-fun-name*)))

+	  (set! *to-do-fun-list*

+		(cons

+		 (list 'define

+		       newname

+		       (list 'lambda

+			     (make-arglist argvars '())

+			     (fetchify (cadr argvars) term)))

+		 *to-do-fun-list*))

+	  (cons newname (make-arglist argvars '())))

+	(cons *op-if* (map (lambda (x) (lift-stat-aux x checkvars))

+			   (cdr term)))))

+   ((eq? (car term) 'begin)

+    (cons *op-begin* (map (lambda (x) (lift-stat-aux x checkvars))

+			  (cdr term))))

+   ((or (eq? (car term) 'let*) (eq? (car term) 'let))

+    (set! checkvars (union (map car (cadr term)) checkvars))

+    (append (list *op-let*)

+	    (list (map (lambda (x) (lift-stat-aux x checkvars))

+		       (cadr term)))

+	    (map (lambda (x) (lift-stat-aux x checkvars))

+		 (cddr term))))

+   ((eq? (car term) 'do)

+    (let ((argvars (free-vars term checkvars '()))

+	  (newname (new-fun-name *current-fun-name*)))

+      (set! *to-do-fun-list*

+	    (cons

+	     (list 'define

+		   newname

+		   (list 'lambda

+			 (make-arglist argvars '())

+			 (fetchify (cadr argvars) term)))

+	     *to-do-fun-list*))

+      (cons newname (make-arglist argvars '()))))

+   ((and (memq (car term) *current-formal-argslist*)

+	 (liftable-hofname? *current-fun-name*))

+    (set! *higher-order-flag* #t)

+    (set! *higher-order-args*

+	  (replaceq (car term) '#t *higher-order-args*))

+    (cons *higher-order-call*

+	  (map (lambda (x) (lift-stat-aux x checkvars)) term)))

+   (else

+    (map (lambda (x) (lift-stat-aux x checkvars)) term))))

+

+

+;;; lift-if-arg? says whether it is needed/sensible to lift

+;;; the if-statement with such a <term> as one of the resulting args

+

+(define (lift-if-arg? term)

+  (and (pair? term)

+       (not (eq? 'quote (car term)))

+       (not (and (memq

+		  (car term)

+		  (cons *not?*

+			(cons *and?*

+			      (cons *or?*

+				    '(eq? = < > <= >=

+					  number? boolean? null? pair? zero?

+					  character? vector?

+					  %= %< %> %<= %>=

+					  %eqv? %number? %zero)))))

+		 (not (member-if (lambda (x) (pair? x)) (cdr term)))))))

+

+

+(define (push-result-var-in var term)

+  (cond ((or (not (pair? term)) (eq? 'quote (car term)))

+	 (if (eq? var *return*)

+	     (list *return* term)

+	     (list 'set! var term)))

+	((eq? (car term) 'if)

+	 (if (eq? 3 (length term))

+	     (list 'if (cadr term)

+		   (push-result-var-in var (caddr term)))

+	     (list 'if (cadr term)

+		   (push-result-var-in var (caddr term))

+		   (push-result-var-in var (cadddr term)))))

+	((eq? (car term) 'begin)

+	 (append (list 'begin)

+		 (butlast (cdr term) 1)

+		 (list (push-result-var-in var

+					   (car (my-last-pair term))))))

+	((or (eq? (car term) 'let*) (eq? (car term) 'let))

+	 (append (list 'let*)

+		 (list (cadr term))

+		 (butlast (cddr term) 1)

+		 (list (push-result-var-in var

+					   (car (my-last-pair term))))))

+	((eq? (car term) 'do)

+	 (append (list 'do)

+		 (list (cadr term))

+		 (list (append

+			(list (car (caddr term)))

+			(if (null? (cdr (caddr term)))

+			    (list (push-result-var-in var *unspecified*))

+			    (append

+			     (butlast (cdr (caddr term)) 1)

+			     (list

+			      (push-result-var-in

+			       var

+			       (car (my-last-pair (caddr term)))))))))

+		 (cdddr term)))

+	;; ((eq? (car term) 'lambda)

+	;;    (report-error

+	;;	"Compiled function " *current-fun-name* " builds closures."))

+	((eq? var *return*)

+	 (if (eq? (car term) *current-fun-name*)

+	     (begin

+	       (set! *tailrec-flag* #t)

+	       (make-tailrec-call (cdr term)))

+	     (list *return* term)))

+	(else

+	 (list 'set! var term))))

+

+

+(define (make-tailrec-call args)

+  (define (first-n-reverse n lst)

+    (if (zero? n) '() (cons (car lst) (first-n-reverse (- n 1) (cdr lst)))))

+  (let ((tmp1 '())

+	(tmp2 '())

+	(tmp3 '()))

+    (set! tmp3 (args->list *current-formal-args*))

+    (set! args (make-listarg-arglist *current-formal-args* args))

+    (do ((args-lst args (cdr args-lst))

+	 (form-lst tmp3 (cdr form-lst)))

+	((null? args-lst))

+      (if (not (equal? (car args-lst) (car form-lst)))

+	  (begin (set! tmp1 (cons (car args-lst) tmp1))

+		 (set! tmp2 (cons (car form-lst) tmp2)))))

+    (set! tmp1 (reverse tmp1))

+    (set! tmp2 (reverse tmp2))

+    (cond

+     ((null? tmp1) (list *goto-tailrec*))

+     ((null? (cdr tmp1))

+      (list 'begin

+	    (list 'set! (car tmp2) (car tmp1))

+	    (list *goto-tailrec*)))

+     (else

+      (let ((tmplist

+	     (first-n-reverse (length tmp1) *tmp-vars*)))

+	(append

+	 (list 'let*)

+	 (list (map (lambda (x y) (list x y)) tmplist tmp1))

+	 (map (lambda (x y) (list 'set! x y)) tmp2 tmplist)

+	 (list (list *goto-tailrec*))))))))

+

+

+(define (make-listarg-arglist formals args)

+  (cond ((list? formals) args)

+	((symbol? formals) (list (normalize-list-aux args)))

+	((null? args)

+	 (report-error

+	  "In "  *current-fun-name*

+	  " a list-taking function is called with too few args."))

+	(else

+	 (cons (car args)

+	       (make-listarg-arglist (cdr formals) (cdr args))))))

+

+

+(define (build-wrappers funs)

+  (define (build-wrapper-aux arity arg)

+    (cond ((null? arity)

+	   '())

+	  ((not (pair? arity))

+	   (list arg))

+	  (else

+	   (cons (list 'car arg)

+		 (build-wrapper-aux (cdr arity) (list 'cdr arg))))))

+  (define (build-wrapper fun)

+    (let* ((name (cadr fun))

+	   (export (assq name *export-table*))

+	   (arity (cadr (caddr fun)))

+	   (arity2 (assq name *dot-arg-templates*)))

+      (if arity2

+	  (set! arity (cadr arity2)))

+      (if (or (not (memq name *export-functions*))

+	      (symbol? arity)

+	      (and (list? arity)

+		   (< (length arity) 4)))

+	  #f

+	  `(define ,(string->symbol

+		     (string-append (symbol->string name)

+				    *wrapper-postfix*))

+	     (lambda (x)

+	       (,*return*

+		(,(if export (cadr export) name)

+		 ,@(build-wrapper-aux arity 'x))))))))

+  (let ((res '()))

+    (for-each (lambda (x)

+		(let ((new (build-wrapper x)))

+		  (if new

+		      (begin

+			(set! res (cons new res))

+			(set! *wrapper-table*

+			      (cons (list (cadr x) (cadr new))

+				    *wrapper-table*))))))

+	      funs)

+    res))

+

+(define (build-wrapped-interpreter-table)

+  (let ((new '())

+	(tmp '()))

+    (do ((part *interpreter-funname-table* (cdr part)))

+	((null? part)

+	 (set! *interpreter-funname-table* new))

+      (set! tmp (assq (caar part) *wrapper-table*))

+      (if tmp

+	  (set! new (cons (cons (cadr tmp) (cdar part)) new))

+	  (begin

+	    (set! tmp (assq (caar part) *export-table*))

+	    (if tmp

+		(set! new (cons (cons (cadr tmp) (cdar part)) new))

+		(set! new (cons (car part) new))))))))

+

+

+

+;===================================================================

+;

+;		vars-simplifying and  lambda-lifting

+;

+;==================================================================

+

+(define *new-vars-nr-for-topfun* 0)

+

+(define (vars-simplify-wholedef def)

+  (let ()

+;;;(pretty-print def)

+    (set! def (compile-quasiquote def))

+;;;(pretty-print def)

+    (set! def (normalize-defines def))

+    (set! *current-fun-name* (cadr def))

+    (set! *top-level-funs* (cons *current-fun-name* *top-level-funs*))

+;;;(pretty-print def)

+    (set! def (if *full-inlining-flag*

+		  (subst-inline-full def)

+		  (subst-inline def)))

+    (set! def (normalize-delay def))

+;;;(pretty-print def)

+    (set! def (rename-vars def))

+    (set! *new-vars-nr-for-topfun* 0)

+    (set! def (normalize def #f 1))

+;;;(pretty-print def)

+    (set! def (normalize-def-letrecs def))

+    (set! def (beautify-lets def))

+;;;(pretty-print def)

+    def))

+

+

+;;; flatten-wholedef performs the first normalizing and lambda-lifting pass

+

+(define (flatten-wholedef def)

+  (let ()

+;;;(newline)

+;;;(display "starting to flatten def: ") (newline)

+;;;(pretty-print def)

+    (set! *current-fun-name* (cadr def))

+    (set! def (lettify-lambdas def 100 #t))

+;;;(pretty-print def)

+    (set! def (remove-lambdasurrounding-let def))

+;;;(pretty-print def)

+    (set! *new-funs-list* '())

+    (set! def (lambda-lift def '() '()))

+;;;(pretty-print def)

+    (set! *new-funs-list* (cons def *new-funs-list*))

+    *new-funs-list*))

+

+

+(define (lambda-lift term boundvars new-names-args)

+  (let ((tmp '()))

+    (cond

+     ((symbol? term)

+      (set! tmp (assq term new-names-args))

+      (if tmp

+	  (cons (cadr tmp) (make-arglist (caddr tmp) '()))

+	  term))

+     ((not (pair? term)) term)

+     ((eq? (car term) 'quote) term)

+     ((eq? (car term) 'lambda)

+      (set! tmp (union (args->list (cadr term)) boundvars))

+      (cons 'lambda

+	    (cons (cadr term)

+		  (map (lambda (x)

+			 (lambda-lift x tmp new-names-args))

+		       (cddr term)))))

+     ((memq (car term) '(let let* letrec))

+      (lift-let term boundvars new-names-args))

+     ((eq? (car term) 'do)

+      ;; check next line!!!

+      (set! tmp (union (map car (cadr term)) boundvars))

+      (cons 'do

+	    (cons (map (lambda (x)

+			 (if (null? (cddr x))

+			     (list (car x)

+				   (lambda-lift (cadr x) boundvars

+						new-names-args))

+			     (list (car x)

+				   (lambda-lift (cadr x) boundvars

+						new-names-args)

+				   (lambda-lift (caddr x)

+						tmp

+						new-names-args))))

+		       (cadr term))

+		  (map (lambda (x)

+			 (lambda-lift x tmp new-names-args))

+		       (cddr term)))))

+     ((symbol? (car term))

+      (set! tmp (assq (car term) new-names-args))

+      (let ((args (map (lambda (x)

+			 (lambda-lift x boundvars new-names-args))

+		       (cdr term))))

+	(if tmp

+	    (cons (cadr tmp)

+		  (make-arglist (caddr tmp) args))

+	    (cons (car term) args))))

+     (else

+      (cons (lambda-lift (car term) boundvars new-names-args)

+	    (map (lambda (x)

+		   (lambda-lift x boundvars new-names-args))

+		 (cdr term)))))))

+

+

+

+(define (lift-let letterm boundvars new-names-args)

+  (let* ((bindings (cadr letterm))

+	 (newvars (map car bindings))

+	 (body (cddr letterm))

+	 (fun-bindings

+	  (filter (lambda (x)

+		    (and (pair? (cadr x))

+			 (eq? (caadr x) 'lambda)))

+		  bindings))

+	 (other-bindings

+	  (filter (lambda (x)

+		    (not (memq x fun-bindings)))

+		  bindings))

+	 (next-bound (union (map car other-bindings) boundvars)))

+

+    (cond ((null? fun-bindings))

+	  ((memq (car letterm) '(let* let))

+	   (set! new-names-args

+		 (make-new-funs-let

+		  fun-bindings next-bound new-names-args #f)))

+	  ((eq? (car letterm) 'letrec)

+	   (set! new-names-args

+		 (make-new-funs-letrec

+		  fun-bindings next-bound new-names-args #f)))

+	  (else (report-error "lift-let applied to non-let term " letterm)))

+

+    (cond ((not (null? other-bindings))

+	   (cons (car letterm)

+		 (cons (map (lambda (x)

+			      (list (car x)

+				    (lambda-lift (cadr x)

+						 next-bound

+						 new-names-args)))

+			    other-bindings)

+		       (map (lambda (x)

+			      (lambda-lift x next-bound new-names-args))

+			    body))))

+	  ((null? (cdr body))

+	   (lambda-lift (car body) next-bound new-names-args))

+	  (else

+	   (lambda-lift (cons 'begin body) next-bound new-names-args)))))

+

+

+(define (fetchify vars term)

+  (if (null? vars) term (fetchify-aux vars term)))

+

+(define (fetchify-aux vars term)

+  (cond ((symbol? term)

+	 (if (memq term vars)

+	     (list *c-fetch* term)

+	     term))

+	((not (pair? term))

+	 term)

+	((eq? 'quote (car term))

+	 term)

+	((and (eq? *c-adr* (car term))

+	      (memq (cadr term) vars))

+	 (cadr term))

+	(else

+	 (cons (fetchify-aux vars (car term))

+	       (fetchify-aux vars (cdr term))))))

+

+

+(define (make-arglist new-args args)

+  (if (null? (cadr new-args))

+      (append (car new-args) args)

+      (append (map (lambda (x) (list *c-adr* x)) (cadr new-args))

+	      (car new-args)

+	      args)))

+

+

+(define (normalize-def-letrecs def)

+  (let ((tmp '()))

+    (set! *current-fun-name* (cadr def))

+    (set! tmp

+	  (normalize-def-letrecs-aux (caddr def)))

+    (list* (car def) (cadr def) (list tmp))))

+

+(define (normalize-def-letrecs-aux term)

+  (cond ((not (pair? term)) term)

+	((eq? 'quote (car term)) term)

+	((eq? 'lambda (car term))

+	 (list* (car term) (cadr term)

+		(map normalize-def-letrecs-aux (cddr term))))

+	((eq? 'letrec (car term))

+	 (if (null? (cadr term))

+	     (list* 'let* '() (map normalize-def-letrecs-aux (cddr term)))

+	     (restructure-letrec (map normalize-def-letrecs-aux term))))

+	(else

+	 (map normalize-def-letrecs-aux term))))

+

+(define (restructure-letrec letterm)

+  (let* ((vars (map car (cadr letterm)))

+	 (dependencies

+	  (map (lambda (x)

+		 (list (car x)

+		       (occurrences-of vars (cadr x))))

+	       (cadr letterm)))

+	 (groups (build-sconnected-groups dependencies vars '())))

+    (set! groups (topo-sort dependencies groups))

+    (build-letrec-struct letterm dependencies groups)))

+

+

+(define (build-letrec-struct letterm deps groups)

+  (if (null? groups)

+      (list (cddr letterm))

+      (let ((bind (filter (lambda (x) (memq (car x) (car groups)))

+			  (cadr letterm)))

+	    (body (build-letrec-struct letterm deps (cdr groups))))

+	(cond

+	 ((and (null? (cdar groups))

+	       (not (memq (caar groups) (cadr (assq (caar groups) deps)))))

+	  (cons 'let

+		(if (symbol? (car body))

+		    (list bind body)

+		    (cons bind (car body)))))

+	 (else

+	  (cons 'letrec

+		(if (symbol? (car body))

+		    (list bind body)

+		    (cons bind (car body)))))))))

+

+;;; lettify-lambdas has a topflag parameter, which is true iff

+;;; the term is a third arg of a toplevel def

+

+(define (lettify-lambdas term var-nr topflag)

+  (cond ((not (pair? term)) term)

+	((eq? 'quote (car term)) term)

+	((memq (car term) '(define lambda))

+	 (if (not (list? (cddr term)))

+	     (report-error

+	      *current-fun-name* " has incorrect syntax."))

+	 (cons (car term)

+	       (cons (cadr term)

+		     (map (lambda (x) (lettify-lambdas x var-nr topflag))

+			  (cddr term)))))

+	((and (pair? term)

+	      (not (list? term)))

+	 (report-error

+	  *current-fun-name* " has incorrect syntax."))

+	((memq (car term) '(let let* letrec))

+	 (if (not topflag)

+	     (cons (car term)

+		   (list* (map (lambda (x)

+				 (list (car x)

+				       (lettify-lambdas

+					(cadr x) var-nr #f)))

+			       (cadr term))

+			  (lettify-lambdas (cddr term) var-nr #f)))

+	     (cons (car term)

+		   (list* (map (lambda (x)

+				 (list (car x)

+				       (lettify-lambdas

+					(cadr x) var-nr #f)))

+			       (cadr term))

+			  (map

+			   (lambda (x) (lettify-lambdas x var-nr #f))

+			   (cddr term))))))

+

+	((and (memq (car term) '(cond))

+	      (find-if (lambda (cl)

+			 (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))

+				  (cdr cl)))

+		       (cdr term)))

+	 (let* ((lcl

+		 (find-if (lambda (cl)

+			    (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x))))

+				     (cdr cl)))

+			  (cdr term)))

+		(lterm

+		 (find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x)))) lcl))

+		(newvar (make-new-funname))

+		(newlcl (replaceq lterm newvar lcl))

+		(newclauses (replaceq lcl newlcl (cdr term))))

+	   `(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))

+	      ,(lettify-lambdas

+		(cons 'cond newclauses) (+ 1 var-nr) #f))))

+	((find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x)))) term)

+

+	 (let* ((lterm (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))

+				term))

+		(newvar (make-new-funname))

+		(newterm (replaceq lterm newvar term)))

+	   `(let ((,newvar ,(lettify-lambdas lterm  (+ 1 var-nr) #f)))

+	      ,(lettify-lambdas newterm (+ 1 var-nr) #f))))

+	(else

+	 (map (lambda (x) (lettify-lambdas x var-nr #f)) term))))

+

+

+(define (make-new-funname)

+  (set! *new-fun-nr* (+ 1 *new-fun-nr*))

+  (let ((name

+	 (string->symbol

+	  (string-append (symbol->string *current-fun-name*)

+			 *new-letfun-infix*

+			 (number->string *new-fun-nr*)))))

+    (set! *new-fun-names* (cons name *new-fun-names*))

+    name))

+

+

+(define (beautify-lets term)

+  (cond ((not (pair? term)) term)

+	((eq? 'quote (car term)) term)

+	((eq? (car term) 'lambda)

+	 (cons (car term)

+	       (cons (cadr term)

+		     (map beautify-lets (cddr term)))))

+	((and (memq (car term) '(let let*))

+	      (eq? 3 (length term))

+	      (pair? (caddr term))

+	      (memq (car (caddr term)) '(let let*)))

+	 (beautify-lets

+	  (list* 'let*

+		 (map beautify-lets

+		      (append (cadr term) (cadr (caddr term))))

+		 (cddr (caddr term)))))

+	(else (map beautify-lets term))))

+

+

+;--------------------------------------------------------------

+;

+;		topological sorting by dependencies

+;

+;--------------------------------------------------------------

+

+(define (topo-sort deps groups)

+  (let ((res (cons '() '())))

+    (do ((part groups (cdr part)))

+	((null? part) (cdr res))

+      (topo-insert (car part) res deps))))

+

+(define (topo-insert el lst deps)

+  (let ((found-flag #f))

+    (do ((last-part lst (cdr last-part)))

+	((or found-flag (null? (cdr last-part)))

+	 (if (not found-flag)

+	     (set-cdr! last-part (list el)))

+	 lst)

+      (if (is-path? (caadr last-part) (car el) deps '())

+	  (begin

+	    (set-cdr! last-part (cons el (cdr last-part)))

+	    (set! found-flag #t))))))

+

+(define (build-sconnected-groups deps input groups)

+  (let ((tmp '()))

+    (cond

+     ((null? input) groups)

+     ((begin (set! tmp

+		   (find-if

+		    (lambda (grp)

+		      (and (not (null? (cdr grp)))

+			   (is-path? (car input) (car grp) deps '())

+			   (is-path? (car grp) (car input) deps '())))

+		    groups))

+	     tmp)

+      (build-sconnected-groups deps (cdr input)

+			       (cons (cons (car input) tmp) (remove tmp groups))))

+     ((begin (set! tmp

+		   (find-if

+		    (lambda (in)

+		      (and (is-path? (car input) in deps '())

+			   (is-path? in (car input) deps '())))

+		    (cdr input)))

+	     tmp)

+      (build-sconnected-groups deps (remove tmp (cdr input))

+			       (cons (list (car input) tmp) groups)))

+     (else

+      (build-sconnected-groups deps (cdr input)

+			       (cons (list (car input)) groups))))))

+

+

+(define (is-path? a b deps visited)

+  (set! visited (cons a visited))

+  (set! a (cadr (assq a deps)))

+  (or (memq b a)

+      (find-if (lambda (x)

+		 (and (not (memq x visited))

+		      (is-path? x b deps visited)))

+	       a)))

+

+(define (occurrences-of vars term)

+  (cond ((symbol? term)

+	 (if (memq term vars)

+	     (list term)

+	     '()))

+	((not (pair? term)) '())

+	((eq? (car term) 'quote) '())

+	(else

+	 (union (occurrences-of vars (car term))

+		(occurrences-of vars (cdr term))))))

+

+

+;---------------------------------------------------------------------

+;

+;		   build auxiliary functions

+;

+;--------------------------------------------------------------------

+

+

+(define (make-new-funs-let fun-bindings boundvars new-names-args lazy-flag)

+  (for-each

+   (lambda (b)

+     (let* ((freevars (merge-free-vars

+		       (introduced-free-vars (cadr b) new-names-args)

+		       (free-vars (cadr b) boundvars '())))

+	    (new-name (make-new-funname))

+	    (tmp (list 'define

+		       new-name

+		       (cons (caadr b)

+			     (cons (make-arglist freevars (cadadr b))

+				   (map (lambda (y)

+					  (fetchify

+					   (cadr freevars)

+					   (lambda-lift

+					    y

+					    (union (args->list (cadadr b))

+						   boundvars)

+					    new-names-args)))

+					(cddadr b)))))))

+       (set! *new-funs-list* (cons tmp *new-funs-list*))

+       (set! new-names-args

+	     (cons (list (car b) new-name freevars)

+		   new-names-args))))

+   fun-bindings)

+  new-names-args)

+

+(define (make-new-funs-letrec fun-bindings boundvars new-names-args lazy-flag)

+  (let* ((fun-bodies (cons 'begin (map cadr fun-bindings)))

+	 (intro-vars (introduced-free-vars fun-bodies new-names-args))

+	 (freevars (merge-free-vars intro-vars

+				    (free-vars fun-bodies boundvars '())))

+	 (new-names-args

+	  (append

+	   (map (lambda (b)

+		  (list (car b) (make-new-funname) freevars))

+		fun-bindings)

+	   new-names-args)))

+    (for-each

+     (lambda (b)

+       (set! *new-funs-list*

+	     (cons

+	      (list 'define

+		    (cadr (assq (car b) new-names-args))

+		    (cons (caadr b)

+			  (cons (make-arglist freevars (cadadr b))

+				(map (lambda (y)

+				       (fetchify (cadr freevars)

+						 (lambda-lift y

+							      (union

+							       (args->list (cadadr b))

+							       boundvars)

+							      new-names-args)))

+				     (cddadr b)))))

+	      *new-funs-list*)))

+     fun-bindings)

+    new-names-args))

+

+

+(define (introduced-free-vars term names-args)

+  (if (null? names-args)

+      (list '() '())

+      (introduced-free-vars-aux term names-args)))

+

+(define (introduced-free-vars-aux term names-args)

+  (cond ((symbol? term)

+	 (let ((tmp (assq term names-args)))

+	   (if tmp (caddr tmp) '(() ()))))

+	((not (pair? term)) '(() ()))

+	((eq? 'quote (car term)) '(() ()))

+	(else

+	 (merge-free-vars

+	  (introduced-free-vars-aux (car term) names-args)

+	  (introduced-free-vars-aux (cdr term) names-args)))))

+

+

+(define (new-fun-name a)

+  (if (memq a *new-fun-names*)

+      a

+      (string->symbol

+       (string-append (symbol->string a)

+		      *new-fun-infix*

+		      (begin (set! *new-fun-nr* (+ 1 *new-fun-nr*))

+			     (number->string *new-fun-nr*))))))

+

+

+;-------------------------------------------------------------------

+;

+;		    free-vars collectors

+;

+;------------------------------------------------------------------

+

+

+;;; all-free-vars takes a term and returns a list (a set) of all

+;;; all free variables in term.

+

+(define (all-free-vars term)

+  (set! *free-vars-list* '())

+  (all-free-aux! term '())

+  *free-vars-list*)

+

+(define (all-free-aux! term bound)

+  (cond

+   ((symbol? term)

+    (if (and (not (memq term bound))

+	     (not (memq term *free-vars-list*)))

+	(set! *free-vars-list* (cons term *free-vars-list*))))

+   ((not (pair? term)))

+   ((eq? 'quote (car term)))

+   ((eq? 'lambda (car term))

+    (let ((new (union (args->list (cadr term)) bound)))

+      (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))

+   ((eq? 'let (car term))

+    (let ((new (union (map car (cadr term)) bound)))

+      (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))

+      (for-each (lambda (x) (all-free-aux! x new)) (cddr term))))

+   ((eq? 'let* (car term))

+    (for-each (lambda (x)

+		(all-free-aux! (cadr x) bound)

+		(if (not (memq (car x) bound))

+		    (set! bound (cons (car x) bound))))

+	      (cadr term))

+    (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))

+   ((eq? 'letrec (car term))

+    (set! bound (union (map car (cadr term)) bound))

+    (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))

+    (for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))

+   ((eq? 'do (car term))

+    (let ((new (union (map car (cadr term)) bound)))

+      (for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))

+      (for-each (lambda (x)

+		  (if (not (null? (cddr x)))

+		      (all-free-aux! (caddr x) new)))

+		(cadr term))

+      (for-each (lambda (x) (all-free-aux! x new)) (caddr term))

+      (for-each (lambda (x) (all-free-aux! x new)) (cdddr term))))

+   (else

+    (for-each (lambda (x) (all-free-aux! x bound)) term))))

+

+

+;;; free-vars takes a term, a list of candidates for free vars (vars bound

+;;; somewhere higher in the term) and a list of bound variables.

+;;; The list of candidates is used in order not to consider the global

+;;; variables (external function definitions, *vars*, etc) to be free.

+;;; It returns a list of two disjoint sets: (<ordinary-free> <set!-free>),

+;;; where <set!-free> is a list of free variables which have a set!

+;;; applied to them somewhere in the term.

+;;;	The differentiation is important, as ordinary (non-set!)

+;;; free variables are passed as ordinary additional variables

+;;; during lambda-lifting, whereas set!-variables have to be passed

+;;; by reference and treated accordingly (fortunately this is simple

+;;; in C: instead of x always write (*x)).

+

+

+(define (free-vars term checkvars boundvars)

+  (cond ((and (symbol? term) (memq term checkvars))

+	 (if (memq term boundvars)

+	     '(() ())

+	     (list (list term) '())))

+	((not (pair? term)) '(() ()))

+	((eq? (car term) 'quote) '(() ()))

+	((eq? (car term) 'set!)

+	 (if (or (memq (cadr term) boundvars)

+		 (not (memq (cadr term) checkvars)))

+	     (free-vars (caddr term) checkvars boundvars)

+	     (merge-free-vars (list '() (list (cadr term)))

+			      (free-vars (caddr term) checkvars boundvars))))

+	((eq? (car term) 'lambda)

+	 (free-vars (cddr term)

+		    checkvars

+		    (append (args->list (cadr term))

+			    boundvars )))

+	((memq (car term) '(let let* letrec))

+	 (free-vars (append (map cadr (cadr term))

+			    (cddr term))

+		    checkvars

+		    (append (map car (cadr term))

+			    boundvars )))

+	((eq? (car term) 'do)

+	 (free-vars (append (map cadr (cadr term))

+			    (map (lambda (x)

+				   (if (null? (cddr x)) 1 (caddr x)))

+				 (cadr term))

+			    (cddr term))

+		    checkvars

+		    (append (map car (cadr term))

+			    boundvars )))

+	(else

+	 (merge-free-vars (free-vars (car term) checkvars boundvars)

+			  (free-vars (cdr term) checkvars boundvars)))))

+

+(define (merge-free-vars pair-a pair-b)

+  (let* ((norm-a (car pair-a))

+	 (norm-b (car pair-b))

+	 (set-a  (cadr pair-a))

+	 (set-b  (cadr pair-b))

+	 (set-res (union set-a set-b)))

+    (list (set-difference (union norm-a norm-b) set-res)

+	  set-res )))

+

+(define *var-nr* 0)

+

+;================================================================

+;

+;	     substituting in inlined-functions and

+;	      converting one-arg map-s to map1-s

+;

+;================================================================

+

+

+(define (subst-inline-full term)

+  (let ((new (subst-inline term)))

+    (if (equal? term new)

+	term

+	(subst-inline-full new))))

+

+

+(define (subst-inline term)

+  (cond ((symbol? term)

+	 (let ((tmp (assq term *inline-vars-data*)))

+	   (if tmp (cadr tmp) term)))

+	((not (pair? term)) term)

+	((eq? 'quote (car term))

+	 term)

+	((and (eq? (car term) 'map)

+	      (= 3 (length term))

+	      (not *always-map->do-flag*)

+	      (guaranteed-all-liftable? (list (car term) (cadr term))))

+	 (set! *map1-needed-flag* #t)

+	 (if (or (pair? (cadr term))

+		 (top-nonlist-in-file-defined? (cadr term)))

+	     (subst-inline (cons *map1-function* (cdr term)))

+	     (subst-inline

+	      (list *map1-function*

+		    `(lambda (x) (,(cadr term) x))

+		    (caddr term)))))

+	((and (eq? (car term) 'for-each)

+	      (= 3 (length term))

+	      (not *always-for-each->do-flag*)

+	      (guaranteed-all-liftable? (list (car term) (cadr term))))

+	 (set! *for-each1-needed-flag* #t)

+	 (if (or (pair? (cadr term))

+		 (top-nonlist-in-file-defined? (cadr term)))

+	     (subst-inline (cons *for-each1-function* (cdr term)))

+	     (subst-inline

+	      (list *for-each1-function*

+		    `(lambda (x) (,(cadr term) x))

+		    (caddr term)))))

+	((memq (car term) *inline-funs*)

+	 (let ((data (assq (car term) *inline-funs-data*))

+	       (tmp (subst-inline (cdr term))))

+	   (subst-inline-aux

+	    (caddr (cadr data))

+	    (map (lambda (par arg)

+		   (list par arg))

+		 (cadr (cadr data))

+		 tmp))))

+	((and (eq? (car term) 'set!)

+	      (assq (cadr term) *inline-vars-data*))

+	 (cons 'set! (cons (cadr term) (map subst-inline (cddr term)))))

+	((list? term)

+	 (map subst-inline term))

+	(else

+	 term)))

+

+

+(define (subst-inline-aux term pairs)

+  (cond ((symbol? term)

+	 (let ((tmp (assq term pairs)))

+	   (if tmp

+	       (cadr tmp)

+	       term)))

+	((not (pair? term))

+	 term)

+	(else

+	 (cons (subst-inline-aux (car term) pairs)

+	       (subst-inline-aux (cdr term) pairs)))))

+

+;================================================================

+;

+;	     normalization (simplifying transformation)

+;

+;================================================================

+

+;;; normalize is a main normalizing function, which should

+;;; normalize a term in one pass.

+;;;

+;;; MB! Quasiquote-compiler, normalize-defines and rename-vars

+;;; must have been applied before the application of the current

+;;; transformer.

+

+(define (normalize term bool-flag var-nr)

+  (cond ((not (pair? term)) term)

+	((eq? (car term) 'quote) term)

+	((memq (car term) '(set! set-car! set-cdr! vector-set!))

+	 (list 'begin

+	       (map (lambda (x) (normalize x bool-flag var-nr)) term)

+	       *unspecified*))

+	((eq? (car term) 'if)

+	 (normalize-if (cdr term) bool-flag var-nr))

+	((eq? (car term) 'cond)

+	 (normalize-cond (cdr term) bool-flag var-nr))

+	((eq? (car term) 'not)

+	 (normalize-not (cdr term) bool-flag var-nr))

+	((eq? (car term) 'and)

+	 (normalize-and (cdr term) bool-flag var-nr))

+	((eq? (car term) 'or)

+	 (normalize-or (cdr term) bool-flag var-nr))

+	((eq? (car term) 'case)

+	 (normalize-case term bool-flag var-nr))

+	((eq? (car term) 'do)

+	 (normalize-do (cdr term) bool-flag var-nr))

+	((eq? (car term) 'lambda)

+	 (cons (car term)

+	       (cons (cadr term)

+		     (normalize (cddr term) bool-flag var-nr))))

+	((eq? 'letrec (car term))

+	 ;;(restructure-letrec

+	 ;;	 (map (lambda (x) (normalize x bool-flag var-nr)) term))

+	 (map (lambda (x) (normalize x bool-flag var-nr)) term))

+        ((modified-fun? (car term))

+	 (map (lambda (x) (normalize x bool-flag var-nr)) term))

+

+	((eq? (car term) 'list)

+	 (normalize-list term bool-flag var-nr))

+	((eq? (car term) 'for-each)

+	 (for-each->do term bool-flag var-nr))

+	((eq? (car term) 'map)

+	 (map->do term bool-flag var-nr))

+	((eq? (car term) 'open-input-file)

+	 (normalize-open-input-file (cdr term) bool-flag var-nr))

+	((eq? (car term) 'open-output-file)

+	 (normalize-open-output-file (cdr term) bool-flag var-nr))

+	((eq? (car term) 'call-with-input-file)

+	 (normalize-call-with-input-file (cdr term) bool-flag var-nr))

+	((eq? (car term) 'call-with-output-file)

+	 (normalize-call-with-output-file (cdr term) bool-flag var-nr))

+	((eq? (car term) 'with-input-from-file)

+	 (normalize-with-input-from-file (cdr term) bool-flag var-nr))

+	((eq? (car term) 'with-output-to-file)

+	 (normalize-with-output-to-file (cdr term) bool-flag var-nr))

+	((eq? 'string-append (car term))

+	 (normalize-string-append term bool-flag var-nr))

+	((assq (car term) *associative-fun-table*)

+	 (normalize-associative

+	  (assq (car term) *associative-fun-table*)

+	  (cdr term) bool-flag var-nr))

+	((assq (car term) *comparison-fun-table*)

+	 (normalize-comparison

+	  (assq (car term) *comparison-fun-table*)

+	  (cdr term) bool-flag var-nr))

+	(else

+	 (map (lambda (x) (normalize x bool-flag var-nr)) term))))

+

+

+;;; for-each->do converts a for-each application to a do cycle.

+;;; The aim is to convert a do cycle into the C for cycle later.

+;;;

+;;; NB! here and in the following transformers bool-flag denotes

+;;; whether the current term occurs as a term of boolean type -

+;;; eg, (if (for-each ....) term1 term2). This allows some

+;;; optimizations (although not directly in for-each, of course).

+;;;

+;;; var-nr is a number of the last generated new variable.

+

+

+(define (for-each->do term bool-flag var-nr)

+  (let* ((fun (cadr term))

+	 (args (cddr term))

+	 (names (map (lambda (x)

+		       (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))

+		     args )))

+    `(do

+	 ,(map (lambda (x y) (list x y (list 'cdr x)))

+	       names

+	       (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))

+	 ,(list (normalize

+		 (if (null? (cdr args))

+		     (list 'not (list 'pair? (car names)))

+		     (list 'not (cons 'and (map (lambda (x)

+						  (list 'pair? x))

+						names))))

+		 #t var-nr)

+		*unspecified*)

+       ,(cons (normalize fun #f (+ 1 var-nr))

+	      (map (lambda (x) (list 'car x)) names)))))

+

+

+;;; map->do converts a map application to a do cycle.

+

+(define (map->do term bool-flag var-nr)

+  (let* ((fun (cadr term))

+	 (args (cddr term))

+	 (res (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))

+	 (res-end (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))

+	 (tmp (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))

+	 (names (map (lambda (x)

+		       (set! var-nr (+ 1 var-nr)) (make-new-var var-nr))

+		     args )))

+    `(do

+	 (,@(map (lambda (x y) (list x y (list 'cdr x)))

+		 names

+		 (map (lambda (x) (normalize x #f (+ 1 var-nr))) args))

+	  (,res '())

+	  (,res-end '())

+	  (,tmp '()))

+	 ,(list (normalize

+		 (if (null? (cdr args))

+		     (list 'not (list 'pair? (car names)))

+		     (list 'not (cons 'and (map (lambda (x)

+						  (list 'pair? x))

+						names))))

+		 #t var-nr)

+		res)

+       (set! ,tmp ,(normalize

+		    (cons fun (map (lambda (x) (list 'car x)) names))

+		    #f (+ 1 var-nr)))

+       (if (null? ,res)

+	   (begin (set! ,res (cons ,tmp '()))

+		  (set! ,res-end ,res))

+	   (begin (set-cdr! ,res-end (cons ,tmp '()))

+		  (set! ,res-end (cdr ,res-end)))))))

+

+

+

+(define (normalize-if term bool-flag var-nr)

+  (if (null? (cddr term))

+      (list 'if

+	    (normalize (car term) #t var-nr)

+	    (normalize (cadr term) bool-flag var-nr)

+	    *unspecified*)

+      (list 'if

+	    (normalize (car term) #t var-nr)

+	    (normalize (cadr term) bool-flag var-nr)

+	    (normalize (caddr term) bool-flag var-nr))))

+

+

+(define (normalize-do term bool-flag var-nr)

+  (if (or (null? (car term))

+	  (null? (cdar term)))

+      (list* 'do

+	     (map (lambda (x) (normalize x #f var-nr))

+		  (car term))

+	     (cons (normalize (caadr term) #t var-nr)

+		   (map (lambda (x) (normalize x #f var-nr))

+			(cdadr term)))

+	     (map (lambda (x) (normalize x #f var-nr))

+		  (cddr term)))

+      (begin

+	(let* ((actual (filter (lambda (x) (not (null? (cddr x))))

+			       (car term)))

+	       (non-actual (filter (lambda (x) (null? (cddr x)))

+				   (car term)))

+	       (vars (map car actual))

+	       (inits (map cadr actual))

+	       (bodies (map caddr actual))

+	       (new-var '())

+	       (new-var-pairs '())

+	       (new-bodies '()))

+	  (do ((part actual (cdr part))

+	       (vars-part vars (cdr vars-part))

+	       (bodies-part bodies (cdr bodies-part)))

+	      ((null? part))

+	    (if (inside-term? (car vars-part) (cdr bodies-part))

+		(begin

+		  (set! var-nr (+ 1 var-nr))

+		  (set! new-var (make-new-var var-nr))

+		  (set! new-var-pairs

+			(cons (list new-var (car vars-part))

+			      new-var-pairs))

+		  (set! bodies-part

+			(cons (car bodies-part)

+			      (subst-term new-var

+					  (car vars-part)

+					  (cdr bodies-part))))

+		  (set! new-bodies

+			(cons (car bodies-part) new-bodies)))

+		(begin

+		  (set! new-bodies

+			(cons (car bodies-part) new-bodies)))))

+	  (if (null? new-var-pairs)

+	      (list* 'do

+		     (map (lambda (x) (normalize x #f var-nr))

+			  (car term))

+		     (cons (normalize (caadr term) #t var-nr)

+			   (map (lambda (x) (normalize x #f var-nr))

+				(cdadr term)))

+		     (map (lambda (x) (normalize x #f var-nr))

+			  (cddr term)))

+	      (list 'let*

+		    (append

+		     non-actual

+		     (map (lambda (x) (list (car x) *dummy*)) new-var-pairs))

+		    (list* 'do

+			   (map (lambda (x y z)

+				  (list x (normalize y #f var-nr)

+					(normalize z #f var-nr)))

+				vars

+				inits

+				(reverse new-bodies))

+			   (cons (normalize (caadr term) #t var-nr)

+				 (map (lambda (x) (normalize x #f var-nr))

+				      (cdadr term)))

+			   (append (map (lambda (x) (normalize x #f var-nr))

+					(cddr term))

+				   (map (lambda (x) (cons 'set! x))

+					new-var-pairs)))))))))

+

+

+

+

+;;; normalize-cond is one of the main transformers.

+;;; It converts a cond to the if-ladder, introducing

+;;; lets and new variables where needed.

+;;;

+;;; NB! In the following *and?* and *or?* are special new functions,

+;;; which are considered to be strictly boolean, and can be

+;;; converted directly to corresponding C operators.

+

+(define (normalize-cond term bool-flag var-nr)

+  (cond

+   ((null? term) *unspecified*)

+   ((null? (cdar term))

+    (if bool-flag

+	`(*and?* ,(normalize (caar term) #t var-nr)

+		 ,(normalize-cond (cdr term) #t var-nr))

+	(let ((new-var (make-new-var (+ 1 var-nr))))

+	  `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))

+	     (if ,new-var ,new-var

+		 ,(normalize-cond (cdr term) #f var-nr))))))

+   ((eq? (cadar term) '=>)

+    (let ((new-var (make-new-var (+ 1 var-nr))))

+      `(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))

+	 (if ,new-var

+	     ,(normalize (list (caddar term) new-var)

+			 bool-flag (+ 1 var-nr))

+	     ,(normalize-cond (cdr term) bool-flag (+ 1 var-nr))))))

+   ((eq? (caar term) 'else)

+    (if (null? (cddar term))

+	(normalize (cadar term) bool-flag var-nr)

+	(normalize (cons 'begin (cdar term)) bool-flag var-nr)))

+   ((null? (cddar term))

+    `(if ,(normalize (caar term) #t var-nr)

+	 ,(normalize (cadar term) bool-flag var-nr)

+	 ,(normalize-cond (cdr term) bool-flag var-nr)))

+   (else

+    `(if ,(normalize (caar term) #t var-nr)

+	 ,(normalize (cons 'begin (cdar term)) bool-flag var-nr)

+	 ,(normalize-cond (cdr term) bool-flag var-nr)))))

+

+

+;;; normalize-not creates a c-not (*not?* => !) or a scheme-not (not)

+

+(define (normalize-not lst bool-flag var-nr)

+  (if bool-flag

+      (normalize (cons *not?* lst) #t var-nr)

+      (list 'not (normalize (car lst) #t var-nr))))

+

+;;; normalize-and and normalize-or make some optimizations

+;;; and convert terms to if-ladders of *and?* and *or?*.

+

+(define (normalize-and lst bool-flag var-nr)

+  (cond ((null? lst) #t)

+	((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))

+	((and bool-flag (not *lift-and-or-flag*))

+	 (normalize (cons *and?* lst) #t var-nr))

+	(else

+	 `(if ,(normalize (car lst) #t var-nr)

+	      ,(normalize-and (cdr lst) bool-flag var-nr)

+	      #f ))))

+

+

+(define (normalize-or lst bool-flag var-nr)

+  (cond ((null? lst) #f)

+	((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))

+	((and bool-flag (not *lift-and-or-flag*))

+	 (normalize (cons *or?* lst) #t var-nr))

+	(bool-flag

+	 `(if ,(normalize (car lst) #t var-nr)

+	      #t

+	      ,(normalize-or (cdr lst) #t var-nr)))

+	(else

+	 (normalize `(cond ,@(map list (butlast lst 1))

+			   (else ,(car (my-last-pair lst))))

+		    bool-flag var-nr ))))

+

+

+;;; normalize-case does the obvious thing.

+

+(define (normalize-case term bool-flag var-nr)

+  (let* ((new-var (make-new-var (+ 1 var-nr)))

+	 (tmp

+	  `(let* ((,new-var ,(cadr term)))

+	     (cond

+	      ,@(normalize-case-aux new-var (cddr term))))))

+    (normalize tmp bool-flag (+ 1 var-nr))))

+

+

+(define (normalize-case-aux var lst)

+  (cond ((null? lst) '())

+	((eq? (caar lst) 'else) (list (car lst)))

+	((list? (caar lst))

+	 (append (map (lambda (x) `((eqv? (quote ,x) ,var) ,@(cdar lst)))

+		      (caar lst))

+		 (normalize-case-aux var (cdr lst))))

+	(else (report-error "Bad case clause syntax:" lst))))

+

+

+

+;;; file-opening and calling with normalization assumes a single

+;;; generic file opening two-arg function *open-file-function* and

+;;; corresponding strings for input and output.

+;;; Calling with files is normalized into a let with assuming

+;;; a function *set-current-input-port-function* and a function

+;;;  *set-current-output-port-function*

+

+(define (normalize-open-input-file term bool-flag var-nr)

+  (list *open-file-function*

+	(normalize (car term) #f var-nr)

+	*input-file-modifier*))

+

+(define (normalize-open-output-file term bool-flag var-nr)

+  (list *open-file-function*

+	(normalize (car term) #f var-nr)

+	*output-file-modifier*))

+

+(define (normalize-with-input-from-file term bool-flag var-nr)

+  (let* ((new-var1 (make-new-var (+ 1 var-nr)))

+	 (new-var2 (make-new-var (+ 2 var-nr)))

+	 (new-var3 (make-new-var (+ 3 var-nr))))

+    `(let* ((,new-var1 (,*open-file-function*

+			,(normalize (car term) #f new-var3)

+			,*input-file-modifier*))

+	    (,new-var2 (,*set-current-input-port-function* ,new-var1))

+	    (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))

+       (close-input-port ,new-var1)

+       (,*set-current-input-port-function* ,new-var2)

+       ,new-var3)))

+

+(define (normalize-with-output-to-file term bool-flag var-nr)

+  (let* ((new-var1 (make-new-var (+ 1 var-nr)))

+	 (new-var2 (make-new-var (+ 2 var-nr)))

+	 (new-var3 (make-new-var (+ 3 var-nr))))

+    `(let* ((,new-var1 (,*open-file-function*

+			,(normalize (car term) #f new-var3)

+			,*output-file-modifier*))

+	    (,new-var2 (,*set-current-output-port-function* ,new-var1))

+	    (,new-var3 (,(normalize (cadr term) bool-flag new-var3))))

+       (,*set-current-output-port-function* ,new-var2)

+       (close-output-port ,new-var1)

+       ,new-var3)))

+

+(define (normalize-call-with-input-file term bool-flag var-nr)

+  (let* ((new-var1 (make-new-var (+ 1 var-nr)))

+	 (new-var2 (make-new-var (+ 2 var-nr))))

+    `(let* ((,new-var1 (,*open-file-function*

+			,(normalize (car term) #f new-var2)

+			,*input-file-modifier*))

+	    (,new-var2 (,(normalize (cadr term) bool-flag new-var2)

+			,new-var1)))

+       (close-input-port ,new-var1)

+       ,new-var2)))

+

+

+(define (normalize-call-with-output-file term bool-flag var-nr)

+  (let* ((new-var1 (make-new-var (+ 1 var-nr)))

+	 (new-var2 (make-new-var (+ 2 var-nr))))

+    `(let* ((,new-var1 (,*open-file-function*

+			,(normalize (car term) #f new-var2)

+			,*output-file-modifier*))

+	    (,new-var2 (,(normalize (cadr term) bool-flag new-var2)

+			,new-var1)))

+       (close-output-port ,new-var1)

+       ,new-var2)))

+

+

+;;; The following normalize-comparisons and

+;;; normalize-associative convert associative functions into

+;;; functions of exactly the arity two. List function is replaced

+;;; by a corresponding cons structure.

+

+(define (normalize-list term bool-flag var-nr)

+  (normalize (normalize-list-aux (cdr term)) bool-flag var-nr))

+

+(define (normalize-list-aux lst)

+  (cond ((null? lst) ''())

+	((null? (cdr lst)) `(cons ,(car lst) '()))

+	(else

+	 `(cons ,(car lst)

+		,(normalize-list-aux (cdr lst))))))

+

+(define (normalize-list-for-c lst)

+  (cond ((null? lst) '())

+	((null? (cdr lst)) `(cons ,(car lst) ()))

+	(else

+	 `(cons ,(car lst)

+		,(normalize-list-for-c (cdr lst))))))

+

+(define (normalize-comparison data lst bool-flag var-nr)

+  (cond ((null? lst) (report-error "too few args in comparison " (car data)))

+	((null? (cdr lst))

+	 (report-error "too few args in comparison " (car data)))

+	((null? (cddr lst))

+	 (list (car data)

+	       (normalize (car lst)  #f var-nr)

+	       (normalize (cadr lst) #f var-nr)))

+	;;at least three args left

+	(else (list *and?*

+		    (normalize-comparison data (butlast lst 1)

+					  #t var-nr)

+		    (let* ((rev (reverse lst))

+			   (tmp (list

+				 (normalize (cadr rev) #t var-nr)

+				 (normalize (car rev) #t var-nr))))

+		      (cons (car data) tmp))))))

+

+

+(define (normalize-string-append term bool-flag var-nr)

+  (list (car term)

+	(normalize (normalize-list-aux (cdr term)) #f var-nr)))

+

+

+(define (normalize-associative data lst bool-flag var-nr)

+  (cond ((null? lst) (cadr data))

+	((null? (cdr lst))

+	 (list (car data)

+	       (cadr data)

+	       (normalize (car lst) (boolean? (cadr data)) var-nr)))

+	((null? (cddr lst))

+	 (list (car data)

+	       (normalize (car lst) (boolean? (cadr data))  var-nr)

+	       (normalize (cadr lst) (boolean? (cadr data)) var-nr)))

+	;;at least three args left

+	((boolean? (cadr data))		; *or?* and *and?*

+	 (list (car data)

+	       (normalize (car lst) #t var-nr)

+	       (normalize-associative data (cdr lst) #t var-nr)))

+	(else

+	 (list (car data)

+	       (normalize-associative data (butlast lst 1) #f var-nr)

+	       (normalize (car (my-last-pair lst)) #f var-nr)))))

+

+

+(define *associative-fun-table*

+  (append

+   (list (cons *or?* '(#f bool)) (cons *and?* '(#t bool)))

+

+   '((append '() lst) ;;; (string-append "" str)

+     (+ 0 num) (- 0 num) (* 1 num) (/ 1 num) (max -99999 num) (min 99999 num)

+     (%+ 0 num) (%- 0 num) (%* 1 num) (%/ 1 num))))

+

+(define *comparison-fun-table*

+  '((= num) (< num) (> num) (<= num) (>= num)

+    (%= num) (%< num) (%> num) (%<= num) (%>= num)

+    (char=? chr) (char<? chr) (char>? chr) (char<=? chr) (char>=? chr)

+    (char-ci=? chr) (char-ci<? chr) (char-ci>? chr)

+    (char-ci<=? chr) (char-ci>=? chr)

+    (string=? str) (string<? str) (string>? str) (string<=? str) (string>=? str)

+    (string-ci=? str) (string-ci<? str) (string-ci>? str)

+    (string-ci<=? str) (string-ci>=? str)))

+

+; pre-4d-version:

+;(define (make-new-var nr)

+;  (string->symbol (string-append *new-var-name* (number->string nr))))

+

+; from-4d-version:

+(define (make-new-var nr)

+  (set! *new-vars-nr-for-topfun* (+ 1 *new-vars-nr-for-topfun*))

+  (string->symbol (string-append *new-var-name*

+				 (number->string *new-vars-nr-for-topfun*))))

+

+;==================================================================

+;

+;		  delay transformer

+;

+;=================================================================

+

+

+;;; The following normalizes applications of 'delay'.

+;;; It should be used as a preprocessor to normalizer.

+

+(define (normalize-delay term)

+  (cond ((not (pair? term)) term)

+	((not (some-in-fun-position? '(delay force) term))

+	 term)

+	((eq? (car term) 'quote) term)

+	((eq? (car term) 'lambda)

+	 `(lambda ,(cadr term) ,@(normalize-delay (cddr term))))

+	((eq? (car term) 'define)

+	 (cons 'define

+	       (cons (cadr term)

+		     (normalize-delay (cddr term)))))

+	((and (eq? (car term) 'delay)

+	      (pair? (cdr term))

+	      (null? (cddr term)))

+	 `(,*make-promise-function*

+	   (lambda () ,(normalize-delay (cadr term)))))

+	((and (eq? (car term) 'force)

+	      (pair? (cdr term))

+	      (null? (cddr term)))

+	 `(,*force-function* ,(normalize-delay (cadr term))))

+	(else

+	 (map normalize-delay term))))

+

+

+;==================================================================

+;

+;		  quasiquote transformer

+;

+;=================================================================

+

+

+;;; The following compiles quasiquotes. It should be used as a

+;;; preprocessor to normalizer. It should compile the full

+;;; quasiquote syntax, including nested quasiquotes.

+

+(define (compile-quasiquote term)

+  (cond ((not (pair? term)) term)

+	((not (occurs-in-function-position? 'quasiquote term)) term)

+	((eq? (car term) 'quote) term)

+	((eq? (car term) 'lambda)

+	 `(lambda ,(cadr term) ,@(compile-quasiquote (cddr term))))

+	((eq? (car term) 'define)

+	 (cons 'define

+	       (cons (cadr term)

+		     (compile-quasiquote (cddr term)))))

+	((eq? (car term) 'quasiquote)

+	 (normalize-quasiquote (cadr term) 1))

+	(else

+	 (map compile-quasiquote term))))

+

+

+(define (normalize-quasiquote term depth)

+  (cond

+;;;     ((not (or (occurs-in-function-position? 'unquote term)

+;;;		(occurs-in-function-position? 'unquote-splicing term)))

+;;;	 `(quote ,term))

+   ((vector? term)

+    `(apply vector ,(normalize-quasiquote (vector->list term) depth)))

+   ((not (pair? term))

+    `(quote ,term))

+   ((and (eq? (car term) 'unquote) (eqv? depth 1))

+    (car (compile-quasiquote (cdr term))))

+   ((not (pair? (car term)))

+    `(cons (quote ,(car term))

+	   ,(normalize-quasiquote (cdr term) depth)))

+   ((eq? (caar term) 'unquote)

+    (if (eqv? depth 1)

+	`(cons ,(compile-quasiquote (cadar term))

+	       ,(normalize-quasiquote (cdr term) depth))

+	(list 'cons

+	      (list  'cons

+		     ''unquote

+		     (normalize-quasiquote (cdar term) (- depth 1)))

+	      (normalize-quasiquote (cdr term) depth))))

+   ((eq? (caar term) 'unquote-splicing)

+    (if (eqv? depth 1)

+	`(append ,(compile-quasiquote (cadar term))

+		 ,(normalize-quasiquote (cdr term) depth))

+	(list 'cons

+	      (list  'cons

+		     ''unquote-splicing

+		     (normalize-quasiquote (cdar term) (- depth 1)))

+	      (normalize-quasiquote (cdr term) depth))))

+   ((eq? (caar term) 'quasiquote)

+    `(cons ,(normalize-quasiquote (car term) (+ 1 depth))

+	   ,(normalize-quasiquote (cdr term) depth)))

+   (else

+    `(cons ,(normalize-quasiquote (car term) depth)

+	   ,(normalize-quasiquote (cdr term) depth)))))

+

+

+

+

+(define (occurs-in-function-position? f term)

+  (and (pair? term)

+       (or (and (eq? (car term) f) (list? (cdr term)))

+	   (occurs-in-function-position? f (car term))

+	   (occurs-in-function-position? f (cdr term)))))

+

+;=============================================================

+;

+;          removing topmost surrounding let's

+;

+;===========================================================

+

+

+(define (remove-lambdasurrounding-let def)

+  (if (and (list? def)

+	   (eq? 3 (length def))

+	   (pair? (caddr def))

+	   (or (eq? 'let (car (caddr def)))

+	       (eq? 'let* (car (caddr def))))

+	   (pair? (cddr (caddr def)))

+	   (pair? (caddr (caddr def)))

+	   (null? (cdddr (caddr def)))

+	   (eq? 'lambda (car (caddr (caddr def)))))

+      (remove-lambdasurrounding-let-aux def)

+      def))

+

+(define (remove-lambdasurrounding-let-aux def)

+  (let* ((letbindings (cadr (caddr def)))

+	 (lambdaterm (caddr (caddr def))))

+    (set! *global-vars-list*

+	  (append *global-vars-list* (map car letbindings)))

+    (set! *top-actions-list*

+	  (append  (map (lambda (x)

+			  (let ((name (make-constant-name)))

+			    (set! *var-make-list*

+				  (cons

+				   (list 'set! (car x)

+					 (list 'scm-gc-protect

+					       (list *c-adr* name)))

+				   *var-make-list*))

+			    (set! *via-interpreter-defined*

+				  (cons (car x) *via-interpreter-defined*))

+			    (list 'set! (car x) (cadr x))))

+			letbindings)

+		   *top-actions-list*))

+    (list (car def) (cadr def) lambdaterm)))

+

+

+

+

+;=============================================================

+;

+;		      variable renaming

+;

+;============================================================

+

+

+;;; rename-vars performs a very important function: it renames

+;;; vars, removing clashes of bound variable names.

+;;; rename-vars tries to rename as few variables as possible;

+;;; in doing that it takes into account that all variable declarations

+;;; in the term should be liftable to the very top of the term.

+;;;

+;;; After applying rename-vars, all variable bindings in lets can

+;;; (and should) be changed to simple set!s in the corresponding order.

+;;;

+;;; That is, the resulting let is actually a let*, or, better yet,

+;;; (let ((a b) ... (g h)) ...) should be treated

+;;; as (begin (set! a b) ... (set! g h) ...).

+;;; All the variables introduced in such lets should be declared

+;;; as local variables of a pointer type in the corresponding

+;;; c function, and set! should be translated to = in the

+;;; obvious way. Thus the resulting let can be translated to the

+;;; C block, for example.

+;;;

+;;; NB! Different types of lets (including the one in do) are all

+;;; converted to the scheme explained above.

+;;;

+;;; NB! Letrec is not handled fully here, in the sense that when

+;;; we perform lambda-lifting, there are some special complexities

+;;; which must be handled.

+

+

+(define *passed-locvars-list* '())

+

+(define (rename-vars term)

+  (set! *var-nr* 0)

+  (set! *passed-locvars-list* '())

+  (set! *free-vars-list* (all-free-vars term))

+  (rename-vars-aux term '() #t))

+

+

+;;; rename-vars-aux takes a topflag, which is true iff term is NOT yet

+;;; inside some lambdaterm. In that case all the vars bound in let are

+;;; renamed by a global scheme in order to be initialized in the

+;;; initialization function.

+

+(define (rename-vars-aux term env topflag)

+  (cond

+   ((symbol? term)

+    (cond ((assq term env) => cdr)

+	  (else term)))

+   ((not (pair? term)) term)

+   ((eq? 'quote (car term)) term)

+   ((eq? 'lambda (car term))

+    `(lambda

+	 ,@(rename-vars-aux (cdr term)

+			    (make-new-env-lambda

+			     (args->list (cadr term))

+			     env)

+			    #f)))

+   ((eq? 'let (car term))

+    (let ((new-env (make-new-env (map car (cadr term)) env topflag)))

+      `(let

+	   ,(map (lambda (x)

+		   (list (rename-vars-aux (car x) new-env topflag)

+			 (rename-vars-aux (cadr x) env topflag)))

+		 (cadr term))

+	 ,@(rename-vars-aux (cddr term) new-env topflag))))

+   ((eq? 'do (car term))

+    (let ((new-env (make-new-env (map car (cadr term)) env #f)))

+      `(do

+	   ,(map (lambda (x)

+		   (cons (rename-vars-aux (car x) new-env #f)

+			 (cons (rename-vars-aux (cadr x) env #f)

+			       (rename-vars-aux (cddr x)

+						new-env #f))))

+		 (cadr term))

+	   ,@(rename-vars-aux (cddr term) new-env #f))))

+   ((eq? 'let* (car term))

+    (let ((new-env env)

+	  (old-env env)

+	  (new-args '()))

+      (do ((part (cadr term) (cdr part)))

+	  ((null? part)

+	   `(let

+		,(reverse new-args)

+	      ,@(rename-vars-aux (cddr term) new-env topflag)))

+	(set! old-env new-env)

+	(set! new-env (make-new-env (list (caar part)) new-env topflag))

+	(set! new-args

+	      (cons (list (rename-vars-aux (caar part) new-env topflag)

+			  (rename-vars-aux

+			   (cadar part) old-env topflag))

+		    new-args )))))

+   ((eq? 'letrec (car term))

+    (let ((new-env (make-new-env (map car (cadr term)) env topflag)))

+      `(letrec ,@(rename-vars-aux (cdr term) new-env topflag))))

+   ((eq? 'define (car term))

+    (map (lambda (x) (rename-vars-aux x env topflag)) term))

+   ((list? term)

+    (map (lambda (x) (rename-vars-aux x env #f)) term))

+   (else (cons (rename-vars-aux (car term) env #f)

+	       (rename-vars-aux (cdr term) env #f)))))

+

+

+(define (args->list args)

+  (cond ((symbol? args) (list args))

+	((list? args)

+	 (map (lambda (x) (if (pair? x) (cadr x) x)) args))

+	((pair? args)

+	 (cons (if (pair? (car args)) (cadar args) (car args))

+	       (args->list (cdr args))))

+	(else (report-error "Bad argument list:" args))))

+

+

+(define (make-new-env vars env topflag)

+  (let ((name '()))

+    (append (map (lambda (x)

+		   (cond

+		    ((or (memq x *new-fun-names*)

+			 (and (not (assq x env))

+			      (not topflag)

+			      (not (memq x *keywords*))

+			      (not (memq x *primitives*))

+			      (not (memq x *top-level-names*))

+			      (not (memq x *passed-locvars-list*))

+			      (not (memq x *free-vars-list*))))

+		     (set! *passed-locvars-list*

+			   (cons x *passed-locvars-list*))

+		     (cons x x))

+		    ((not topflag)

+		     (set! *var-nr* (+ 1 *var-nr*))

+		     (cons x

+			   (string->symbol

+			    (string-append

+			     (symbol->string x)

+			     *local-var-infix*

+			     (number->string *var-nr*)))))

+		    (else

+		     (set! *new-fun-nr* (+ 1 *new-fun-nr*))

+		     (cons x

+			   (string->symbol

+			    (string-append

+			     (symbol->string x)

+			     *new-fun-infix*

+			     (number->string *new-fun-nr*)))))))

+		 vars)

+	    env )))

+

+(define (make-new-env-lambda vars env)

+  (append (map (lambda (x)

+		 (if (or (assq x env)

+			 (memq x *keywords*)

+			 (memq x *primitives*)

+			 (memq x *top-level-names*))

+		     (cons x

+			   (string->symbol

+			    (string-append

+			     (symbol->string x)

+			     *local-var-infix*

+			     (begin (set! *var-nr* (+ 1 *var-nr*))

+				    (number->string *var-nr*)))))

+		     (cons x x)))

+	       vars )

+	  env ))

+

+

+;===============================================================

+;

+;		  define - transformer

+;

+;===============================================================

+

+;;; normalize-defines converts fancy defines into basic ones.

+

+(define (normalize-defines term)

+  (cond

+   ((not (pair? term)) term)

+   ((eq? (car term) 'quote) term)

+   ((eq? (car term) 'define)

+    ;; the coming if removes let in the case:

+    ;; (define foo (let ((bar bar)) ...))

+    ;;  (if (and (pair? (cdr term))

+    ;;		(pair? (cddr term))

+    ;;		(pair? (caddr term))

+    ;;		(memq (car (caddr term)) '(let let* letrec))

+    ;;		(pair? (cadr (caddr term)))

+    ;;		(not (find-if (lambda (x) (not (eq? (car x) (cadr x))))

+    ;;			   (cadr (caddr term)))))

+    ;;	   (set! term (cons 'define (cons (cadr term) (cddr (caddr term))))))

+    (if (pair? (cadr term))

+	`(define ,(caadr term)

+	   ,(normalize-defines

+	     (cons 'lambda (cons (cdadr term) (cddr term)))))

+	`(define ,(cadr term) ,(normalize-defines (caddr term)))))

+   ((and (memq (car term) '(let* letrec))

+	 (not (list? (cadr term))))

+    (report-error

+     "In " *current-fun-name* " there is wrong let: " term))

+

+    ;;; the next case rewrites a named let to a letrec, never succeeds.

+   ((begin

+      (if (and (eq? (car term) 'let)

+	       (not (null? (cdr term)))

+	       (not (null? (cddr term)))

+	       (symbol? (cadr term))

+	       (not (null? (cadr term))))

+	   ;;; a named let

+	  (if (find-if (lambda (x)

+			 (or (null? x) (not (list? x)) (null? (cdr x))))

+		       (caddr term))

+	      (report-error

+	       *current-fun-name*

+	       " contains an incorrect named let: " term)

+	      (let ((param (map car (caddr term)))

+		    (args  (map cadr (caddr term))))

+		(set! term

+		      (list 'letrec

+			    (list

+			     (list (cadr term)

+				   (list* 'lambda param (cdddr term))))

+			    (cons (cadr term) args))))))

+      #f))

+   ((and (memq (car term) '(lambda let let* letrec do))

+	 (pair? (caddr term))

+	 (eq? 'define (caaddr term)))

+    (let ((defs (normalize-defines-aux (cddr term)))

+	  (other (member-if

+		  (lambda (x)

+		    (or (not (pair? x)) (not (eq? (car x) 'define))))

+		  (cddr term))))

+      (if (not other) (report-error "Body is missing:" term))

+      `(,(car term)

+	,(normalize-defines (cadr term))

+	,(normalize-defines (cons 'letrec (cons defs other))))))

+   ((list? term)

+    (map normalize-defines term))

+   (else

+    (cons (normalize-defines (car term))

+	  (normalize-defines (cdr term))))))

+

+

+(define (normalize-defines-aux lst)

+  (if (and (not (null? lst)) (pair? (car lst)) (eq? 'define (caar lst)))

+      (cons (cdr (normalize-defines (car lst)))

+	    (normalize-defines-aux (cdr lst)))

+      '()))

+

+;=================================================================

+;

+;                     Global analysis

+;

+;=================================================================

+

+

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+;

+;            analysis for liftability and mutability

+;

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+

+

+; lift-analyse-def! takes a def where all the lambdas are renamed

+; (by taking extra let-s with names), vars are renamed and letrecs

+; are ordered.

+;

+; it dest. changes the def body by replacing the leading lambda of

+; all the liftable lambdaterms with the value of *liftable-lambda*

+

+

+(define *local-liftnames* '())

+(define *liftable-lambda* '**liftable-lambda**)

+(define *def-hofname* '())

+

+(define (lift-analyse-def! def)

+  (let* ((funname (cadr def))

+         (lterm (caddr def)))

+    (set! *local-liftnames* '())

+    (set! *def-hofname* funname)

+    (lift-analyse-def-aux! lterm)

+    (if (and (pair? lterm)

+	     (not (all-liftable? (cdr lterm))))

+	(set! *not-all-liftable-names*

+	      (cons funname *not-all-liftable-names*)))))

+

+

+; lift-analyse-def-aux! term:

+;  term is a term

+;

+;  all lambdaterms must be named.

+;

+;  liftable lambdas are destr. replaced by *liftable-lambda*,

+;  their names are added to *local-liftnames*

+;

+

+(define (lift-analyse-def-aux! term)

+  (let* ((name '())

+	 (passed '())

+	 (tmp '()))

+    (cond

+     ((not (pair? term)))

+     ((eq? 'quote (car term)))

+     ((eq? 'lambda (car term))

+      (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))

+;;;      ((eq? *liftable-lambda* (car term))

+;;;         (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))

+     ((and (pair? (car term))

+	   (eq? 'lambda (caar term)))

+      (for-each lift-analyse-def-aux! (cddar term))

+      (if (all-liftable? (cddar term))

+	  (set-car! (car term) *liftable-lambda*))

+      (for-each lift-analyse-def-aux! (cdr term)))

+     ((memq (car term) '(let* let))

+      (for-each lift-analyse-def-aux! (cddr term))

+      (do ((part (reverse (cadr term)) (cdr part)))

+	  ((null? part))

+	(set! name (caar part))

+	(lift-analyse-def-aux! (cadar part))

+	(if (and (pair? (cadar part))

+		 (eq? 'lambda (caadar part))

+		 (all-liftable? (cddr (cadar part)))

+		 (liftable-nameocc? name (cddr (cadar part)))

+		 (liftable-nameocc? name (cons 'begin passed))

+		 (liftable-nameocc? name (cons 'begin (cddr term))))

+	    (begin

+	      (set! *local-liftnames*

+		    (cons name *local-liftnames*))

+	      (set-car! (cadar part) *liftable-lambda*)))

+	(set! passed (cons (cadar part) passed))))

+     ((eq? (car term) 'letrec)

+      (for-each lift-analyse-def-aux! (cddr term))

+      (for-each (lambda (el) (lift-analyse-def-aux! (cadr el))) (cadr term))

+      (if (and (every1 (lambda (el)

+			 (and (pair? (cadr el))

+			      (eq? 'lambda (caadr el))

+			      (all-liftable? (cddr (cadr el)))))

+		       (cadr term))

+	       (every1 (lambda (el)

+			 (and (liftable-nameocc? (car el)

+						 (cons 'begin (cddr term)))

+			      (every1 (lambda (el2)

+					(liftable-nameocc?

+					 (car el) (cddr (cadr el2))))

+				      (cadr term))))

+		       (cadr term)))

+	  (for-each (lambda (el)

+		      (set! *local-liftnames*

+			    (cons (car el) *local-liftnames*))

+		      (set-car! (cadr el) *liftable-lambda*))

+		    (cadr term))))

+     ((and (liftable-hofname? (car term))

+	   (not (eq? (car term) *def-hofname*)))

+      (set! tmp (assq (car term) *liftable-hof-database*))

+      ;;  (if tmp (begin (newline) (display "term: ") (display term) (newline)))

+      (if tmp

+	  ;; case for top-level def of a higher-order fun:

+	  (if (every1 (lambda (x)

+			;;  (newline) (display "x: ") (display x) (newline)

+			(let ((param (car x))

+			      (arg (cdr x)))

+			  ;;  (display "param: ") (display param) (newline)

+			  ;;  (display "arg: ") (display arg) (newline)

+			  (if param

+			      (or (and (pair? arg)

+				       (or (eq? 'lambda (car arg))

+					   (eq? *liftable-lambda*

+						(car arg)))

+				       (begin

+					 (for-each

+					  lift-analyse-def-aux!(cddr arg))

+					 ;; (newline) (display "cddr arg:")

+					 ;; (display (cddr arg)) (newline)

+					 (all-liftable? (cddr arg))))

+				  (and (symbol? arg)

+				       (memq arg *top-level-names*)

+				       (not (modified-fun? arg))))

+			      #t)))

+		      (map cons (cdr tmp) (cdr term)))

+	      (for-each (lambda (param arg)

+			  (if (and param

+				   (pair? arg)

+				   (eq? 'lambda (car arg))

+				   (all-liftable? (cddr arg)))

+			      (set-car! arg *liftable-lambda*)))

+			(cdr tmp)

+			(cdr term))

+	      (let ((name

+		     (string->symbol

+		      (string-append (symbol->string (car term))

+				     *export-hof-postfix*))))

+		(set! *top-level-names*

+		      (cons name *top-level-names*))

+		(set-car! term name)))

+	  ;; case for map and for-each:

+	  (for-each (lambda (arg)

+		      (if (and (pair? arg)

+			       (eq? 'lambda (car arg)))

+			  (set-car! arg *liftable-lambda*)))

+		    (cdr term)))

+      (for-each (lambda (x) (lift-analyse-def-aux! x)) (cdr term)))

+     (else

+      (for-each (lambda (x) (lift-analyse-def-aux! x)) term)))))

+

+

+(define (all-liftable? term)

+  (cond ((not (pair? term)) (not (eq? 'lambda term)))

+	((eq? 'quote (car term)) #t)

+	(else (and (all-liftable? (car term))

+		   (all-liftable? (cdr term))))))

+

+(define (guaranteed-all-liftable? term)

+  (cond ((not (pair? term)) (not (eq? 'lambda term)))

+	((eq? 'quote (car term)) #t)

+	((and (or (eq? 'map (car term)) (eq? 'for-each (car term))

+		  (eq? *map1-function* (car term))

+		  (eq? *for-each1-function* (car term)))

+	      (pair? (cdr term))

+	      (pair? (cadr term)))

+	 (and (guaranteed-all-liftable? (cdadr term))

+	      (guaranteed-all-liftable? (cddr term))))

+	(else (and (guaranteed-all-liftable? (car term))

+		   (guaranteed-all-liftable? (cdr term))))))

+

+(define (lift-unmark-def! term)

+  (cond

+   ((not (pair? term)))

+   ((eq? 'quote (car term)))

+   ((eq? *liftable-lambda* (car term))

+    (set-car! term 'lambda)

+    (for-each lift-unmark-def! (cdr term)))

+   ((list? term)

+    (for-each lift-unmark-def! term))

+   (else term)))

+

+

+; liftable-nameocc? name term:

+;   name a name of some fun,

+;   term is the term where the use of name is checked.

+;

+; gives #f iff name is used in the nonliftable context

+

+(define (liftable-nameocc? name term)

+  (cond

+   ((not (pair? term)) #t)

+   ((eq? 'quote (car term)) #t)

+   ((eq? 'lambda (car term))

+    (not (inside-term? name (cddr term))))

+   ((and (memq name (cdr term))

+	 (not (liftable-hofname? (car term))))

+    #f)

+   (else

+    (every1 (lambda (x) (liftable-nameocc? name x)) term))))

+

+

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+;

+;           checking liftability of higher-order funs

+;

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+

+(define *liftable-hof-primitives*

+  (list *map1-function* *for-each1-function* 'map 'for-each))

+

+(define (liftable-hofname? name)

+  (and (or (memq name *liftable-hof-primitives*)

+	   (memq name *liftable-hof-names*))

+       (not (modified-fun? name))))

+

+

+; liftable-hof? lterm name:

+;  checks whether lterm with name is a liftable hof

+

+

+(define (liftable-hof? lterm name)

+  (let* ((args (args->list (cadr lterm)))

+         (hof-args  (filter-hof-args lterm args)))

+    (if (and (not (null? hof-args))

+	     (liftable-nameocc? name (cddr lterm))

+	     (not (member-if (lambda (x)

+			       (not (liftable-hofvars-usage?

+				     x name hof-args args)))

+			     (cddr lterm))))

+	(begin

+	  (set! *liftable-hof-database*

+		(cons (cons name (map (lambda (x) (if (memq x hof-args) #t #f))

+				      args))

+		      *liftable-hof-database*))

+	  #t)

+	(if (not (null? hof-args))

+	    (begin (set! *non-liftable-hof-names*

+			 (cons name *non-liftable-hof-names*))

+		   #f)

+	    #f))))

+

+

+; filter-hof-args term args:

+;   filters out the functional args from args

+

+

+(define *found-hof-args* '())

+(define *check-hof-args* '())

+

+(define (filter-hof-args term args)

+  (if (null? args)

+      '()

+      (begin

+        (set! *check-hof-args* args)

+        (set! *found-hof-args* '())

+        (filter-hof-args-aux! term)

+        *found-hof-args*)))

+

+

+(define (filter-hof-args-aux! term)

+  (let* ((tmp '()))

+    (cond

+     ((null? *check-hof-args*))

+     ((not (pair? term)))

+     ((eq? 'quote (car term)))

+     ((eq? 'lambda (car term))

+      (for-each filter-hof-args-aux! (cddr term)))

+     ((begin (set! tmp (memq (car term) *check-hof-args*))

+	     tmp)

+      (set! *found-hof-args* (cons (car tmp) *found-hof-args*))

+      (set! *check-hof-args* (remove-one (car tmp) *check-hof-args*))

+      (for-each filter-hof-args-aux! term))

+     (else

+      (for-each filter-hof-args-aux! term)))))

+

+; liftable-hofvars-usage? term name hof-args:

+;   checks that hof-args are used in the term with name only

+;   in the function position or as same args to name itself and

+;   that the name is not called with lambdaterms at hof-places

+;   and that hof-places are exactly the same args.

+;   hof-args may also not occur in the inside lambda-terms.

+

+(define (liftable-hofvars-usage? term name hof-args args)

+  (cond

+   ((not (pair? term)) #t)

+   ((eq? 'quote (car term)) #t)

+   ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))

+    (not (find-if (lambda (x) (some-inside-term? hof-args x)) (cddr term))))

+   ((eq? name (car term))

+    (every1 (lambda (x)

+	      (let ((param (car x))

+		    (arg (cdr x)))

+		(if (memq param hof-args)

+		    (eq? param arg)

+		    (and (not (memq arg hof-args))

+			 (not (and (pair? arg) (eq? 'lambda (car arg))))))))

+	    (map cons args (cdr term))))

+   (else

+    (and (every1 (lambda (el) (not (memq el hof-args))) (cdr term))

+	 (every1 (lambda (x) (liftable-hofvars-usage? x name hof-args args))

+		 term)))))

+

+

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+;

+;           checking for redefining of functions

+;

+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

+

+

+(define *keywords*

+  '(=> and begin case cond define delay do else if lambda

+       let let letrec or quasiquote quote set! unquote

+       unquote-splicing))

+

+(define (modified-fun? name)

+  (cond

+   (*all-funs-modified-flag*

+    (or (memq name *primitives*)

+	(memq name *top-level-names*)))

+   (*new-funs-modified-flag*

+    (or (memq name *modified-primitives*)

+	(memq name *top-level-names*)))

+   (else

+    (or (memq name *modified-primitives*)

+	(memq name *modified-top-level-names*)))))

+

+(define *top-level-names* '())

+(define *modified-primitives* '())

+(define *modified-top-level-names* '())

+

+(define (make-top-level-namelist! expr-list)

+  (set! *top-level-names* '())

+  (set! *modified-primitives* '())

+  (set! *modified-top-level-names* '())

+  (set! *check-redefining-passed* '())

+  (make-top-level-namelist-aux! expr-list #f)

+;;;  (pretty-print expr-list)

+  (make-top-level-namelist-aux! expr-list #t)

+;;;  (pretty-print expr-list)

+  (set! *modified-primitives*

+	(set-difference *modified-primitives* *general-transcedentals*))

+  *top-level-names*)

+

+(define *general-transcedentals*

+  '(sqrt log expt exp sin cos tan asin acos atan sinh cosh tanh asinh tanh

+	 asinh acosh atanh))

+

+(define (make-top-level-namelist-aux! expr-list redefining-flag)

+  (if (and (pair? expr-list) (list? expr-list))

+      (for-each

+       (lambda (expr)

+	 (cond

+	  ((not (pair? expr)))

+	  ((not (list? expr)))

+	  ((eq? 'quote (car expr)))

+	  ((eq? (car expr) 'define)

+	   (let ((new (normalize-top-define expr)))

+	     (if redefining-flag

+		 (check-redefining! new #t)

+		 (set! *top-level-names*

+		       (cons (cadr new) *top-level-names*)))))

+	  ((and (eq? 'set! (car expr))

+		redefining-flag)

+	   (check-redefining! expr #t))

+	  ((not redefining-flag)

+	   (for-each (lambda (x) (make-top-level-namelist-aux! x #f))

+		     expr))))

+       expr-list)))

+

+(define (compute-floats-flag! term opsflag)

+  (cond (*floats-flag* #t)

+        ((pair? term)

+	 (if (eq? 'quote (car term))

+	     (compute-floats-flag! (cdr term) #f)

+	     (or (compute-floats-flag! (car term) opsflag)

+		 (compute-floats-flag! (cdr term) opsflag))))

+        ((vector? term)

+	 (do ((i (- (vector-length term) 1) (- i 1)))

+	     ((< i 0) *floats-flag*)

+	   (compute-floats-flag! (vector-ref term i) opsflag)))

+        ((number? term)

+	 (if (or (not (integer? term))

+		 (not (exact? term))

+		 (> term most-positive-fixnum)

+		 (< term most-negative-fixnum))

+	     (begin (set! *floats-flag* term) #t)

+	     #f))

+        ((not opsflag) #f)

+        ((symbol? term)

+	 (if (memq term *float-recognize-ops*)

+	     (begin (set! *floats-flag* term) #t)

+	     #f))

+        (else #f)))

+

+

+(define *float-recognize-ops*

+  '($sin $cos $tan $asin $acos $atan $sinh $cosh $tanh $asinh $tanh

+	 $asinh $acosh $atanh $sqrt $expt $log $abs $exp

+	 sin cos tan asin acos atan sinh cosh tanh asinh tanh

+	 asinh acosh atanh))

+

+

+(define *check-redefining-passed* '())

+

+(define (check-redefining! term top-level-flag)

+  (let* ((new '()))

+    (cond

+     ((not (pair? term)))

+     ((not (list? term)))

+     ((eq? 'quote (car term)))

+     ((or (eq? 'set! (car term))

+	  (and top-level-flag (eq? 'define (car term))))

+      (if (eq? 'define (car term))

+	  (set! new (normalize-top-define term))

+	  (set! new term))

+      (if (not (eq? 3 (length term)))

+	  (report-error " wrong set! or define syntax: " term))

+      (if (memq (cadr new) *keywords*)

+	  (report-error " a keyword is set! or defined: " term))

+      (if (memq (cadr new) *primitives*)

+	  (or (memq (cadr new) *modified-primitives*)

+	      (set! *modified-primitives*

+		    (cons (cadr term) *modified-primitives*))))

+      (if (and (memq (cadr new) *top-level-names*)

+	       (not (memq (cadr new) *hobbit-declaration-vars*)))

+	  (or (memq (cadr new) *modified-top-level-names*)

+	      (if (and (eq? 'define (car new))

+		       (not (memq (cadr new) *check-redefining-passed*)))

+		  (set! *check-redefining-passed*

+			(cons (cadr new) *check-redefining-passed*))

+		  (set! *modified-top-level-names*

+			(cons (cadr new) *modified-top-level-names*)))))

+      (check-redefining! (caddr new) #f))

+     ((eq? 'begin (car term))

+      (for-each (lambda (x) (check-redefining! x #t)) term))

+     (else

+      (for-each (lambda (x) (check-redefining! x #f)) term)))))

+

+

+;=====================================================================

+;

+;                      Building closures

+;

+;====================================================================

+

+;(define *closure-name-suffix* "_cl")

+;(define *closure-name-nr* 0)

+;(define *closure-vector-name* "clargsv_")

+;(define *closure-vector-name-nr* 0)

+;(define *closurefun-arg* 'closurearg_0)

+;(define *closurefun-arg-car* 'closurearg_car_0)

+

+; The whole closurebuilding process is carried on top-down breadth-first:

+; there is no excplicit recursion. Instead, once a new closurefun def

+; is created, it is put into the list *lifted-closures-to-do*, which

+; is afterwards passed and the lambdaterms inside these new funs are

+; made into closures again, etc, until *lifted-closures-to-do* is empty.

+

+; try-closure-making-def is the topmost closure-builder applied to a def.

+

+(define (try-closure-making-def def)

+  (let* ((body (caddr def)))

+    (set! *letrec-closure-nr* 0)

+    (cond ((not (pair? body)) def)

+	  ((eq? 'quote (car body)) def)

+	  ((eq? 'lambda (car body)) (try-closure-making-ldef def))

+	  (else  (report-error "try-closure-making-non-ldef called")))))

+

+; try-closure-making-ldef builds closures for lambdaterm-defs.

+; It is never called from anywhere except try-closure-making-def

+; (the topmost closurebuilder)

+

+(define (try-closure-making-ldef def)

+  (let* ((lterm (caddr def))

+         (lvars (args->list (cadr lterm)))

+	 (letvars (collect-local-vars (cddr lterm)))

+	 (vars (union lvars letvars))

+	 ;; closurevars is the subset of set! <vars> inside lambdas:

+	 (closurevars (closure-building-vars (cddr lterm) vars))

+	 (vectname (make-closure-vector-name)))

+    (set! *current-fun-name* (cadr def))

+    (if (null? closurevars)

+	;; no set! closurevars found:

+	(list (car def) (cadr def)

+	      (list* (car lterm) (cadr lterm)

+		     (map (lambda (x)

+			    (cdr (make-closure-making

+				  x vars closurevars

+				  *closurefun-arg-car* vectname)))

+			  (cddr lterm))))

+	;; in the next case some closurevars were found.

+	(let* ((tmp (make-closure-making

+		     (cddr lterm) vars closurevars

+		     *closurefun-arg-car* vectname))

+	       (varsmapping (car tmp))

+	       (newterm (cdr tmp))

+	       (initialize-argsv

+		(make-initialize-closureargsv vectname lvars varsmapping)))

+	  (if (not (null? varsmapping))

+	      (beautify-closure

+	       (list

+		(car def)

+		(cadr def)

+		(cons (car lterm)

+		      (list (cadr lterm)

+			    (cons 'let*

+				  (cons (cons (list vectname

+						    (list 'make-vector

+							  (length closurevars)))

+					      '())

+					(append initialize-argsv

+						newterm)))))))

+	      (beautify-closure

+	       (list

+		(car def)

+		(cadr def)

+		(cons (car lterm)

+		      (list (cadr lterm)

+			    (append initialize-argsv newterm))))))))))

+

+

+; make-closure-vector-name builds a new vector for these local vars

+; which are passed to (and set! inside) closures.

+; default: clargsv_

+;

+; It is called from try-closure-making-ldef, ..-non-ldef, ...-lterm.

+;

+; The created vector-name is added to *closure-var-vectornames*

+; for later recognition as such.

+

+(define (make-closure-vector-name)

+  (set! *closure-vector-name-nr* (+ 1 *closure-vector-name-nr*))

+  (let ((res (string->symbol

+	      (string-append *closure-vector-name*

+			     (number->string *closure-vector-name-nr*)))))

+    (if (not (memq res *closure-var-vectornames*))

+	(set! *closure-var-vectornames* (cons res *closure-var-vectornames*)))

+    res))

+

+; make-closure-name adds a suffix (default: _cl (+nr)) to the

+; argument functionname. The returned name will be used as a name

+; of the created closurefunction.

+;

+; called from: make-closure-making-aux and make-trivial-closuremaking

+

+(define (make-closure-name currentfunname)

+  (set! *closure-name-nr* (+ 1 *closure-name-nr*))

+  (string->symbol (string-append (symbol->string currentfunname)

+				 *closure-name-suffix*

+				 (number->string *closure-name-nr*))))

+

+; make-initialize-closureargsv takes a vectorname

+; (made by make-closure-vector for keeping local vars to be passed),

+; lvars (argument vars of a lambdaterm) and varsmapping

+; (mapping of local vars to be kept in vector 'vectorname' to the

+; elements of this vector)

+;

+; It adds vector-set! to each element of varsmapping and filters

+; out (keeps) exactly these which are in lvars. The resulting

+; sequence of assigments ... (set! (vector-ref clargsv_nrn nrx) x)

+; is inserted into function body after creating vector 'vectorname'

+; in order to use the vector-elements instead of the parametric vars

+; of the lambdaterm.

+;

+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm.

+

+(define (make-initialize-closureargsv vectname lvars varsmapping)

+  (filter-map (lambda (x)

+		(if (memq (car x) lvars)

+		    (list 'vector-set! vectname

+			  (cdr x) (car x))

+		    #f))

+	      varsmapping))

+

+; make-trivial-closuremaking is called in case the argument term

+; contains no mutable vars in the environment, ie when it does not have

+; to be a proper closure at all, but just a function without a

+; local environment. It returns just the name of the function, to

+; be inserted into the surrounding procedure at the place of the

+; original lambdaterm.

+;

+; called from: make-closuremaking-aux and try-closure-making-ldef, ...-lterm.

+

+(define (make-trivial-closuremaking term)

+  (cond

+   ((not (pair? term)) term)

+   ((eq? 'quote (car term)) term)

+   ((eq? 'lambda (car term))

+    (let* ((fun-name (make-closure-name *current-fun-name*))

+	   (procname (make-closure-scmobj-name fun-name))

+	   (newdef (list 'define fun-name term)))

+      (set! *lifted-trivial-closure-names*

+	    (cons fun-name *lifted-trivial-closure-names*))

+      (set! *top-level-funs*

+	    (cons fun-name *top-level-funs*))

+      (if (not (memq procname *special-c-vars*))

+	  (set! *special-c-vars* (cons procname *special-c-vars*)))

+      (set! *lifted-closures-to-do*

+	    (cons newdef *lifted-closures-to-do*))

+      procname))

+   ((not (list? term)) term)

+   (else

+    (map (lambda (x) (make-trivial-closuremaking x)) term))))

+

+; - - - - - - - - - proper closure-body-building begins - - - - - - - -

+

+

+; make-closure-making creates the correct body of the closure (inside

+; non-liftable lambdaterm which is used together with the vector

+; of its environment) together with the creation/instantiation code

+; inserted into the surrounding fun at the place of the original lambdaterm.

+;

+; vars is the set of environment vars, closurevars is the set of

+; set! environment vars.

+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm

+

+(define (make-closure-making term vars closurevars vectname clvectname)

+  (let* ((varsnr (length closurevars))

+	 (tmp -1)

+	 (clvarsmapping (map (lambda (x)

+			       (set! tmp (+ 1 tmp)) (cons x tmp))

+			     closurevars))

+	 (newterm '()))

+    (set! newterm (vars->closureaccess

+		   term '() clvarsmapping vectname clvectname))

+    (begin (set! newterm

+		 (make-closure-making-aux

+		  (cdr newterm) '() vars (map car clvarsmapping)

+		  vectname clvectname))

+	   (cons clvarsmapping newterm))))

+

+

+(define (make-closure-making-aux

+	 term holes vars clvars vectname clvectname)

+  (cond

+   ((not (pair? term)) term)

+   ((eq? 'quote (car term)) term)

+   ((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))

+    (make-closure-making-aux-lterm

+     term holes vars clvars vectname clvectname))

+   ((not (list? term)) term)

+   ((and (eq? 'set! (car term))

+	 (pair? (cdr term))

+	 (pair? (cddr term))

+	 (pair? (caddr term))

+	 ;; if it is not lambda, and is inside-term,

+	 ;; then the set! var must be in clvars.

+	 (eq? 'lambda (caaddr term))

+	 (not (memq (cadr term) clvars))

+	 (inside-term? (cadr term) (caddr term)))

+    (make-closure-making-aux-set!

+     term holes vars clvars vectname clvectname))

+   ((and (eq? 'letrec (car term))

+	 (pair? (cdr term))

+	 ;; if some bound var is inside-nonliftable-term,

+	 ;; and some leading fun is not a (nonliftable)lambda,

+	 ;; then all the bound vars must be in clvars.

+	 (every1 (lambda (el) (eq? 'lambda (caadr el)))

+		 (cadr term))

+	 (find-if (lambda (el) (not (memq (car el) clvars)))

+		  (cadr term)))

+    (make-closure-making-aux-letrec

+     term holes vars clvars vectname clvectname))

+   (else

+    (map (lambda (x)

+	   (make-closure-making-aux

+	    x holes vars clvars vectname clvectname))

+	 term))))

+

+(define (make-closure-making-aux-set!

+	 term holes vars clvars vectname clvectname)

+  (let* ((tmp '())

+	 (newholes (cons (cadr term) holes)))

+    (set! *letrec-closures* '())

+    (set! *letrec-closure-init* '())

+    (set! tmp

+	  (make-closure-making-aux

+	   (caddr term) newholes vars clvars vectname clvectname))

+    (list* 'let* *letrec-closures*

+	   (append (list (list 'set! (cadr term) tmp))

+		   *letrec-closure-init*))))

+

+

+(define (make-closure-making-aux-letrec

+	 letterm holes vars clvars vectname clvectname)

+  (let* ((bindings (cadr letterm))

+	 (body (cddr letterm))

+	 (newbindings '())

+	 (newholes (append (map car bindings) holes)))

+    (set! *letrec-closures* '())

+    (set! *letrec-closure-init* '())

+    (set! newbindings

+	  (map (lambda (el)

+		 (list (car el)

+		       (make-closure-making-aux

+			(cadr el) newholes vars clvars vectname clvectname)))

+	       bindings))

+    (list* 'let* (append *letrec-closures* newbindings)

+	   (append

+	    *letrec-closure-init*

+	    (map (lambda (x)

+		   (make-closure-making-aux

+		    x holes vars clvars vectname clvectname))

+		 body)))))

+

+; make-closure-making-aux-lterm creates the correct body of the closure (inside

+; non-liftable lambdaterm which is used together with the vector

+; of its environment) together with the creation/instantiation code

+; inserted into the surrounding fun at the place of the original lambdaterm.

+;

+; vars is the set of environment vars, closurevars is the set of

+; set! environment vars.

+; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm and

+; recursively from make-closure-making-aux

+

+(define (make-closure-making-aux-lterm

+	 lterm holes vars clvars vectname clvectname)

+  (let ((params (args->list (cadr lterm))))

+    ;; filter out the subsets of vars actually occurring in lterm,

+    ;; previously throwing away these which are bound in lambda-args.

+    (or (null? vars)

+	(set! vars

+	      (filter-inside-term

+	       (filter (lambda (x) (not (memq x params)))

+		       vars)

+	       (cddr lterm))))

+    (cond

+     ((eq? *liftable-lambda* (car lterm))

+      (list* (car lterm) (cadr lterm)

+	     (map (lambda (x)

+		    (make-closure-making-aux

+		     x holes vars clvars vectname clvectname))

+		  (cddr lterm))))

+     ((and (null? vars)

+	   (not (some-inside-term? *closure-var-vectornames* (cddr lterm))))

+      ;; trivial case: no closure has to be built, function suffices

+      (make-trivial-closuremaking lterm))

+     (else

+      ;; nontrivial case: closure has to be built, but there are no

+      ;; set! closurevars to be handled.

+      (let* ((fun-name (make-closure-name *current-fun-name*))

+	     (definf (make-lifted-closure-fun

+		      lterm fun-name vars clvars))

+	     (applic (make-lifted-closure-applic definf holes)))

+	(set! *lifted-closure-names*

+	      (cons fun-name *lifted-closure-names*))

+	(set! *lifted-closures-to-do*

+	      (cons (caddr definf) *lifted-closures-to-do*))

+	applic)))))

+

+; make-lifted-closure-fun builds a body of the lambdaterm which is

+; used as a proper closure.

+;

+; vars is the (nonempty) list of free variables occurring in lterm

+;

+; make-lifted-closure-fun is called only from make-closure-making-aux.

+

+

+(define (make-lifted-closure-fun lterm name vars clvars)

+  (let* ((args (cdr (sort-out-clargs (cadr lterm))))

+	 (passed-clargsv-lst

+	  (filter-inside-term *closure-var-vectornames* (cddr lterm)))

+	 (clargstranslation

+	  (make-wrapped-clargs-init

+	   passed-clargsv-lst *closurefun-arg-car* 1))

+	 (varstranslation

+	  (make-wrapped-clargs-init

+	   vars *closurefun-arg-car* (+ 1 (length passed-clargsv-lst))))

+	 (argstranslation

+	  (make-wrapped-args-init

+	   args *closurefun-arg* 1)))

+    (list

+     vars

+     passed-clargsv-lst

+     (list 'define

+	   name

+	   (list 'lambda

+		 (list *closurefun-arg*)

+		 (cons 'let*

+		       (cons (append

+			      (list (list *closurefun-arg-car*

+					  (list 'car  *closurefun-arg*)))

+			      clargstranslation

+			      varstranslation

+			      argstranslation)

+			     (cddr lterm))))))))

+

+

+; sort-out-clargs takes the parameters of the function to the used as

+; a closure-body. It splits these into the pair of two lists,

+; the car being all these parameters which are closure-var-vectornames

+; and the cdr being these parameters which are not.

+

+; called only from make-lifted-closure-fun.

+

+(define (sort-out-clargs inargs)

+  (let* ((clargs '())

+	 (args '()))

+    (do ((part inargs (cdr part)))

+	((not (pair? part))

+	 (cons (reverse clargs)

+	       (append (reverse args) part)))

+      (if (memq (car part) *closure-var-vectornames*)

+	  (set! clargs (cons (car part) clargs))

+	  (set! args (cons (car part) args))))))

+

+; make-wrapped-clargs-init takes a list of vars which are

+; closure-var-vectornames. It creates a let-initialization-list

+; of the form ((<listel> (vector-ref <closurefun-arg-car> 1) ... (..2) ...)

+

+; called only from make-lifted-closure-fun.

+

+(define (make-wrapped-clargs-init clargs varname nr)

+  (cond

+   ((null? clargs) '())

+   (else

+    (cons (list (car clargs) (list 'vector-ref varname nr))

+	  (make-wrapped-clargs-init (cdr clargs) varname (+ 1 nr))))))

+

+

+; make-wrapped-args-init takes a list of vars which are _not_

+; closure-var-vectornames. It creates a let-initialization-list

+; of the form ((<listel> (begin (set! <closurefun-arg> (cdr closurefun-arg>))

+;                               (car <closurefun-arg>))).

+;

+; called only from make-lifted-closure-fun.

+

+(define (make-wrapped-args-init args varname nr)

+  (cond

+   ((null? args) '())

+   ((not (pair? args))

+    (list (list args (list 'cdr varname))))

+   ((zero? nr)

+    (cons (list (car args)

+		(list 'car varname))

+	  (make-wrapped-args-init (cdr args) varname (+ 1 nr))))

+   (else

+    (cons (list (car args)

+		(list 'begin

+		      (list 'set! varname (list 'cdr varname))

+		      (list 'car varname)))

+	  (make-wrapped-args-init (cdr args) varname (+ 1 nr))))))

+

+

+; make-lifted-closure-applic takes a newly built closurefun body def

+; and creates code for creating the closure and initializing the

+; environment-vector-part of the closure.

+;

+; called only from make-closure-making-aux.

+

+(define (make-lifted-closure-applic definf holes)

+  (let* ((vars (car definf))

+	 (clvects (cadr definf))

+	 (newdef (caddr definf))

+	 (funname (cadr newdef))

+	 (procname (make-closure-scmobj-name funname))

+	 (lterm (caddr newdef))

+	 (lbody (cddr lterm))

+	 (assignments '())

+	 (nr 0)

+	 (closurename (string->symbol *new-closure-var*))

+	 (letrec-assignments '()))

+    (if (not (null? holes))

+	(begin (set! *letrec-closure-nr* (+ 1 *letrec-closure-nr*))

+	       (set! closurename

+		     (string->symbol

+		      (string-append

+		       *new-closure-var*

+		       (string-append

+			"_" (number->string *letrec-closure-nr*)))))))

+    (for-each (lambda (x)

+		(set! nr (+ 1 nr))

+		(set! assignments

+		      (cons (list 'vector-set! closurename nr x)

+			    assignments)))

+	      clvects)

+    (for-each (lambda (x)

+		(set! nr (+ 1 nr))

+		(set! assignments

+		      (cons (list 'vector-set! closurename nr x)

+			    assignments)))

+	      vars)

+    (cond ((null? holes)		; closure does not occur in letrec top

+	   (if (null? assignments)

+	       (list *make-cclo* procname (list *actual-c-int* (+ 1 nr)))

+	       `(let* ((,closurename

+			(,*make-cclo*

+			 ,procname ,(list *actual-c-int* (+ 1 nr)))))

+		  ,@(reverse assignments)

+		  ,closurename)))

+	  (else

+	   (set! letrec-assignments

+		 (filter (lambda (x) (member (cadddr x) holes))

+			 assignments))

+	   (set! assignments

+		 (filter (lambda (x) (not (member x letrec-assignments)))

+			 assignments))

+	   (set! *letrec-closures*

+		 (append *letrec-closures*

+			 (list (list closurename

+				     (list *make-cclo* procname

+					   (list *actual-c-int* (+ 1 nr)))))))

+					; closure occurs in letrec top

+	   (set! *letrec-closure-init*

+		 (append *letrec-closure-init*

+			 (reverse letrec-assignments)))

+	   (if (null? assignments)

+	       closurename

+	       (cons 'begin (append assignments (list closurename))))))))

+

+

+;;  - - - - - - - - - proper closure-body-building ends - - - - - - - -

+

+

+(define (make-closure-scmobj-name funname)

+  (let ((res (string->symbol

+	      (string-append

+	       (symbol->string funname) *closure-proc-suffix*))))

+    (or (memq res *special-c-vars*)

+	(set! *special-c-vars* (cons res *special-c-vars*)))

+    res))

+

+(define (list->conses lst)

+  (if (null? lst)

+      (list 'quote '())

+      (let ((tmp (list->conses (cdr lst))))

+	(list 'cons (car lst) tmp))))

+

+(define (cl-vectorname? symb)

+  (memq symb *closure-var-vectornames*))

+

+;vars->closureaccess takes a term and two mappings of vars to closureaccess.

+; a mapping has the format: (<var> . <nr>)

+;

+; it returns a pair (<flag> . <result-term>) where <flag> is #f iff

+; the term does not contain closurevars.

+;

+; it assumes that vars in let-s, lambda, do have been already renamed

+; so that there are no varname-clashes.

+;

+; called only from make-closure-making and recursively.

+

+(define (vars->closureaccess term varsmap clvarsmap vectname clvectname)

+  (cond

+   ((symbol? term)

+    (set! clvarsmap (assq term clvarsmap))

+    (set! varsmap (assq term varsmap))

+    (cond

+     ((and clvarsmap

+	   (not (memq term *closure-var-vectornames*)))

+      (cons #t (list 'vector-ref clvectname (cdr clvarsmap))))

+     ((and varsmap

+	   (not (memq term *closure-var-vectornames*)))

+      (cons #t (list 'vector-ref vectname (cdr varsmap))))

+     (else

+      (cons #f term))))

+   ((not (pair? term)) (cons #f term))

+   ((eq? 'quote (car term)) (cons #f term))

+   ((eq? *liftable-lambda* (car term))

+    (let* ((vars (args->list (cadr term)))

+	   (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))

+	   (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))

+	   (tmp (vars->closureaccess

+		 (cddr term) newmap newclmap vectname clvectname)))

+      (cons (car tmp) (list* *liftable-lambda* (cadr term) (cdr tmp)))))

+   ((eq? 'lambda (car term))

+    (let* ((vars (args->list (cadr term)))

+	   (newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))

+	   (newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))

+	   (tmp (vars->closureaccess

+		 (cddr term) newmap newclmap vectname clvectname)))

+      (if (car tmp)			; closurevars used?

+					; yes, closurevars used:

+	  (cons #t (cons 'lambda

+			 (cons (cons clvectname (cadr term))

+			       (cdr tmp))))

+					; no, no closurevars were used:

+	  (cons #f term))))

+   (else

+    (let ((tmp (map (lambda (x) (vars->closureaccess

+				 x varsmap clvarsmap vectname clvectname))

+		    term)))

+      (if (find-if (lambda (x) (car x)) tmp)

+	  (cons #t (map cdr tmp))

+	  (cons #f (map cdr tmp)))))))

+

+

+; closure-building-vars assumes that vars in the term are renamed

+;   so that no varname or varname-funname or varname-syntax

+;   conflicts occur.

+; it returns the subset of vars in funvars occurring freely and set!

+; inside lambdaterms in term, plus funvars fi occurring freely in the

+; contexts:

+; (1)  (set! fi t), where t=/=(lambda (...)...) and fi occurs

+; inside a non-liftable lambdaterm in t.

+; (2)  (letrec (... (fi ti) ...) ...), where ti=/=(lambda (...)...) and

+; at least one of fj bound in letrec occurs inside a non-liftable

+; lambdaterm in a tr body in letrec. NB! If some ti=/=(lambda (...)...),

+; the latter condition is automatically guaranteed by previous lifting

+; analysis.

+

+(define *closure-building-vars* '())

+

+(define (closure-building-vars term funvars)

+  (set! *local-vars* funvars)

+  (set! *closure-building-vars* '())

+  (closure-building-vars-aux! term)

+  (filter (lambda (x) (memq x *closure-building-vars*)) funvars))

+

+(define (closure-building-vars-aux! term)

+  (cond

+   ((not (pair? term)))

+   ((eq? 'quote (car term)))

+   ((eq? 'lambda (car term))

+    (for-each (lambda (var)

+		(if (and (not (memq var *closure-building-vars*))

+			 (not (inside-term? var (cadr term)))

+			 (inside-term-set? var (cddr term)))

+		    (set! *closure-building-vars*

+			  (cons var *closure-building-vars*))))

+	      *local-vars*))

+   ((eq? *liftable-lambda* (car term))

+    (for-each closure-building-vars-aux! (cddr term)))

+   ((eq? 'set! (car term))

+    (if (and (pair? (caddr term))

+	     (not (eq? 'lambda (car (caddr term))))

+	     (inside-nonliftable-term? (cadr term) (caddr term))

+	     (not (memq (cadr term) *closure-building-vars*)))

+	(set! *closure-building-vars*

+	      (cons (cadr term) *closure-building-vars*)))

+    (for-each closure-building-vars-aux! (cdr term)))

+   ((eq? 'letrec (car term))

+    (if (and (find-if (lambda (x)

+			(and (pair? (cadr x))

+			     (not (eq? 'lambda (car (cadr x))))))

+		      (cadr term))

+	     (find-if (lambda (x)

+			(find-if (lambda (y)

+				   (inside-nonliftable-term? (car x) (cadr y)))

+				 (cadr term)))

+		      (cadr term)))

+	(for-each (lambda (x)

+		    (or (memq (car x) *closure-building-vars*)

+			(set! *closure-building-vars*

+			      (cons (car x) *closure-building-vars*))))

+		  (cadr term)))

+    (for-each closure-building-vars-aux! (cdr term)))

+   (else

+    (for-each closure-building-vars-aux! term))))

+

+

+(define (inside-nonliftable-term? name term)

+  (cond

+   ((not (pair? term)) #f)

+   ((eq? 'quote (car term)) #f)

+   ((eq? 'lambda (car term))

+    (inside-term? name (cddr term)))

+   (else

+    (find-if (lambda (x) (inside-nonliftable-term? name x)) term))))

+

+(define (inside-term-set? x term)

+  (cond ((not (pair? term)) #f)

+	((eq? 'quote (car term)) #f)

+	((eq? 'set! (car term))

+	 (or (and (pair? (cdr term))

+		  (eq? x (cadr term))

+		  (pair? (cddr term))

+		  (null? (cdddr term)))

+	     (inside-term-set? x (cdr term))))

+	(else

+	 (or (inside-term-set? x (car term))

+	     (inside-term-set? x (cdr term))))))

+

+(define (collect-local-vars term)

+  (set! *local-vars* '())

+  (collect-local-vars-aux term)

+  *local-vars*)

+(define (collect-local-vars-aux term)

+  (cond

+   ((not (pair? term)))

+   ((eq? (car term) 'quote))

+   ((or (eq? (car term) 'let*) (eq? (car term) *op-let*)

+        (eq? (car term) 'let) (eq? (car term) 'letrec))

+    (set! *local-vars*

+	  (union (filter-map

+		  (lambda (el)

+		    (if (and (pair? (cadr el))

+			     (eq? *liftable-lambda* (caadr el)))

+			#f

+			(car el)))

+		  (cadr term))

+		 *local-vars*))

+    (for-each (lambda (x) (collect-local-vars-aux (cadr x))) (cadr term))

+    (for-each (lambda (x) (collect-local-vars-aux x)) (cddr term)))

+   ((eq? (car term) 'do)

+    (set! *local-vars* (union (map car (cadr term)) *local-vars*))

+    (for-each (lambda (x)

+		(for-each (lambda (y) (collect-local-vars-aux y)) (cdr x)))

+	      (cadr term))

+    (for-each (lambda (x) (collect-local-vars-aux x)) (caddr term))

+    (for-each (lambda (x) (collect-local-vars-aux x)) (cdddr term)))

+   ((eq? (car term) 'lambda))

+   (else

+    (for-each (lambda (x) (collect-local-vars-aux x)) term))))

+

+; beautify-closure takes a built closure-fun and corrects the

+; following: (let* (... ((vector-ref foo n) bar) ...) ...) is

+; replaced by (let* (...) (vector-set! foo n bar) (let* (...) ...)),

+; (set! (vector-ref foo n) bar) is replaced by (vector-set! foo n bar)

+(define (beautify-closure term)

+  (cond

+   ((not (pair? term)) term)

+   ((eq? 'quote (car term)) term)

+   ((and (eq? 'set! (car term))

+	 (pair? (cdr term))

+	 (pair? (cadr term))

+	 (eq? 'vector-ref (caadr term))

+	 (pair? (cdadr term))

+	 (pair? (cddr term))

+	 (memq (cadadr term) *closure-var-vectornames*))

+    (list 'vector-set!

+	  (cadadr term) (caddr (cadr term)) (beautify-closure (caddr term))))

+   ((and (memq (car term) '(let* let letrec))

+	 (not (null? (cdr term)))

+	 (pair? (cadr term))

+	 (find-if (lambda (x) (pair? (car x))) (cadr term)))

+    (beautify-closure-let (car term) (cadr term) (cddr term)))

+   ((list? term)

+    (map beautify-closure term))

+   (else

+    term)))

+(define (beautify-closure-let key bindings rest)

+  (if (null? bindings)

+      (cons 'begin (map beautify-closure rest))

+      (let* ((okpart '()))

+	(do ((part bindings (cdr part)))

+	    ((or (null? part)

+		 (and (pair? (car part))

+		      (pair? (caar part))

+		      (eq? 'vector-ref (caaar part))

+		      (pair? (cdaar part))

+		      (memq (cadaar part) *closure-var-vectornames*)))

+	     (if (null? part)

+		 (list* key (reverse okpart) (map beautify-closure rest))

+		 (list key

+		       (reverse okpart)

+		       (list 'vector-set! (cadaar part)

+			     (caddar (car part))

+			     (beautify-closure (cadar part)))

+		       (beautify-closure-let key (cdr part) rest))))

+	  (set! okpart (cons (list (caar part)

+				   (beautify-closure (cadar part)))

+			     okpart))))))

+

+

+

+;====================================================================

+;

+;	       auxiliary functions - a library

+;

+;===================================================================

+

+(define (filter f lst)

+  (cond ((null? lst) '())

+	((f (car lst))  (cons (car lst) (filter f (cdr lst))))

+	(else (filter f (cdr lst)))))

+

+(define (filter-map f lst)

+  (if (pair? lst)

+      (let ((res (f (car lst))))

+	(if res

+	    (cons res (filter-map f (cdr lst)))

+	    (filter-map f (cdr lst))))

+      '()))

+

+(define (filter-inside-term lst term)

+  (define *filter-inside-term-res* '())

+  (define (filter-inside-term-aux! lst term)

+    (cond ((not (pair? term))

+	   (and (memq term lst)

+		(not (memq term *filter-inside-term-res*))

+		(set! *filter-inside-term-res*

+		      (cons term *filter-inside-term-res*))))

+	  ((eq? 'quote (car term)))

+	  (else (filter-inside-term-aux! lst (car term))

+		(filter-inside-term-aux! lst (cdr term)))))

+  (filter-inside-term-aux! lst term)

+  (filter (lambda (x) (memq x *filter-inside-term-res*)) lst))

+

+(define (inside-term? x term)

+  (cond ((eq? x term) #t)

+	((not (pair? term)) #f)

+	((eq? 'quote (car term)) #f)

+	(else (or (inside-term? x (car term))

+		  (inside-term? x (cdr term))))))

+

+(define (some-inside-term? obs term)

+  (cond ((memq term obs) #t)

+	((not (pair? term)) #f)

+	((eq? 'quote (car term)) #f)

+	(else (or (some-inside-term? obs (car term))

+		  (some-inside-term? obs (cdr term))))))

+

+(define (subst-term-equal! what for term)

+  (cond ((not (pair? term)))

+	((equal? (car term) for)

+	 (set-car! term what)

+	 (subst-term-equal! what for (cdr term)))

+	((not (eq? 'quote (car term)))

+	 (subst-term-equal! what for (car term))

+	 (subst-term-equal! what for (cdr term)))))

+

+(define (subst-term what for term)

+  (cond ((eq? term for) what)

+	((not (pair? term)) term)

+	((eq? 'quote (car term)) term)

+	(else (cons (subst-term what for (car term))

+		    (subst-term what for (cdr term))))))

+

+(define (in-fun-position? x term)

+  (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)

+	((not (list? term)) #f)

+	((eq? x (car term)) #t)

+	(else (find-if (lambda (y) (in-fun-position? x y)) term))))

+

+(define (some-in-fun-position? lst term)

+  (cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)

+	((not (list? term)) #f)

+	((memq (car term) lst) #t)

+	(else (find-if (lambda (y) (some-in-fun-position? lst y)) term))))

+

+(define (replaceq what with lst)

+  (cond ((null? lst) '())

+	((eq? what (car lst)) (cons with (replaceq what with (cdr lst))))

+	(else (cons (car lst) (replaceq what with (cdr lst))))))

+

+;;; Like LAST-PAIR, but works for non-lists.

+(define (my-last-pair lst)

+  (define (my-last-pair-aux lst)

+    (if (pair? (cdr lst))

+	(my-last-pair-aux (cdr lst))

+	lst))

+  (if (not (pair? lst))

+      lst

+      (my-last-pair-aux lst)))

+

+;;; Like REMOVE, but removes at most one element.

+(define (remove-one what from)

+  (cond ((null? from) from)

+	((eq? what (car from)) (cdr from))

+	(else (cons (car from) (remove-one what (cdr from))))))

+

+;;; Like FIND-IF, but works for non-lists.

+(define (pair-find-if f lst)

+  (if (pair? lst)

+      (if (f (car lst)) (car lst) (pair-find-if f (cdr lst)))

+      (if (f lst) lst #f)))

+

+;;; slib/comlist.scm functions:

+

+(define (find-if f lst)

+  (if (null? lst)

+      #f

+      (if (f (car lst)) (car lst) (find-if f (cdr lst)))))

+

+(define (remove what lst)

+  (cond ((null? lst) '())

+	((eq? what (car lst)) (remove what (cdr lst)))

+	(else (cons (car lst) (remove what (cdr lst))))))

+

+(define (every1 f lst)

+  (if (null? lst)

+      #t

+      (if (f (car lst)) (every1 f (cdr lst)) #f)))

+

+(define (member-if f lst)

+  (if (null? lst)

+      #f

+      (if (f (car lst)) lst (member-if f (cdr lst)))))

+

+(define (list* obj1 . obj2)

+  (define (list*1 obj)

+    (if (null? (cdr obj))

+	(car obj)

+	(cons (car obj) (list*1 (cdr obj)))))

+  (if (null? obj2)

+      obj1

+      (cons obj1 (list*1 obj2))))

+

+(define (butlast lst n)

+  (letrec

+      ((len (- (length lst) n))

+       (bl (lambda (lst n)

+	     (let build-until-zero ((lst lst)

+				    (n n)

+				    (result '()))

+	       (cond ((null? lst) (reverse result))

+		     ((positive? n)

+		      (build-until-zero

+		       (cdr lst) (- n 1) (cons (car lst) result)))

+		     (else (reverse result)))))))

+    (bl lst (if (negative? n)

+		(slib:error "negative argument to butlast" n)

+		len))))

+

+(define (union lst1 lst2)

+  (define ans (if (null? lst1) lst2 lst1))

+  (define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))

+  (cond ((null? lst2) lst1)

+	(else (for-each (lambda (elt) (set! ans (adjoin elt ans)))

+			lst2)

+	      ans)))

+

+(define (set-difference lst1 lst2)

+  (if (null? lst2)

+      lst1

+      (let build-difference ((lst1 lst1)

+			     (result '()))

+	(cond ((null? lst1) (reverse result))

+	      ((memv (car lst1) lst2) (build-difference (cdr lst1) result))

+	      (else (build-difference (cdr lst1) (cons (car lst1) result)))))))

+

+(define (intersection lst1 lst2)

+  (if (null? lst2)

+      lst2

+      (let build-intersection ((lst1 lst1)

+			       (result '()))

+	(cond ((null? lst1) (reverse result))

+	      ((memv (car lst1) lst2)

+	       (build-intersection (cdr lst1) (cons (car lst1) result)))

+	      (else

+	       (build-intersection (cdr lst1) result))))))

+

+;===========================  END ===============================

diff --git a/hobbit.texi b/hobbit.texi
new file mode 100644
index 0000000..3b448fb
--- /dev/null
+++ b/hobbit.texi
@@ -0,0 +1,2273 @@
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename hobbit.info
+@settitle hobbit
+@include version.txi
+@setchapternewpage on
+@c Choices for setchapternewpage are {on,off,odd}.
+@paragraphindent 0
+@defcodeindex ft
+@syncodeindex ft cp
+@c %**end of header
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* hobbit: (hobbit).   SCM Compiler.
+@end direntry
+
+@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 Hobbit
+@subtitle SCM Compiler
+@subtitle Version @value{SCMVERSION}
+@author by Tanel Tammet
+@author Department of Computing Science
+@author Chalmers University of Technology
+@author University of Go"teborg
+@author S-41296 Go"teborg Sweden
+
+@page
+This Hobbit documentation was converted to texinfo format by Aubrey
+Jaffer; and released as part of the SCM @value{SCMVERSION} distribution
+@value{SCMDATE}.
+
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1990-1999, 2002 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, Introduction, (dir), (dir)
+
+@ifinfo
+Hobbit is an optimizing R4RS-Scheme to C compiler written by Tanel
+Tammet.
+
+@menu
+* Introduction::                
+* Compiling with Hobbit::       
+* The Language Compiled::       
+* Performance of Compiled Code::  
+* Principles of Compilation::   
+* About Hobbit::                
+@end menu
+
+Copyright (C) 1990-1999, 2002 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
+
+
+@node Introduction, Compiling with Hobbit, Top, Top
+@chapter Introduction
+
+Hobbit is a small optimizing scheme-to-C compiler written in Report 4
+scheme and intended for use together with the SCM scheme interpreter of
+A. Jaffer.  Hobbit compiles full Report 4 scheme, except that:
+
+@itemize @bullet
+@item
+It does not fully conform to the requirement of being properly
+tail-recursive: non-mutual tailrecursion is detected, but mutual
+tailrecursion is not.
+@item
+Macros from the Report 4 appendix are not supported (yet):
+only the common-lisp-like defmacro is supported.
+@end itemize
+
+Hobbit treats SCM files as a C library and provides integration of
+compiled procedures and variables with the SCM interpreter as new
+primitives.
+
+Hobbit compiles scheme files to C files and does not provide anything
+else by itself (eg. calling the C compiler, dynamic loading).  Such
+niceties are described in the next chapter @ref{Compiling And Linking}.
+
+Hobbit (derived from hobbit5x) is now part of the SCM Scheme
+implementation.  The most recent information about SCM can be found on
+SCM's @dfn{WWW} home page:
+
+@center @url{http://swissnet.ai.mit.edu/~jaffer/SCM.html}
+
+Hobbit4d has also been ported to the Guile Scheme implementation:
+
+@center @url{http://www.gnu.org/software/guile/anon-cvs.html}
+
+
+@node Compiling with Hobbit, The Language Compiled, Introduction, Top
+@chapter Compiling with Hobbit
+
+@menu
+* Compiling And Linking::       
+* Error Detection::             
+* Hobbit Options::              
+* CC Optimizations::            
+@end menu
+
+@node Compiling And Linking, Error Detection, Compiling with Hobbit, Compiling with Hobbit
+@section Compiling And Linking
+
+@code{(require 'compile)}
+
+@defun hobbit name1.scm name2.scm @dots{}
+Invokes the HOBBIT compiler to translate Scheme files
+@file{@var{name1}.scm}, @file{@var{name2}.scm}, @dots{} to C files
+@file{@var{name1}.c} and @file{@var{name1}.h}.
+@end defun
+
+@defun compile-file name1.scm name2.scm @dots{}
+Compiles the HOBBIT translation of @var{name1}.scm, @var{name2}.scm,
+@dots{} to a dynamically linkable object file
+@var{name1}<object-suffix>, where <object-suffix> is the object file
+suffix for your computer (for instance, @file{.so}).  @var{name1}.scm
+must be in the current directory; @var{name2}.scm, @dots{} may be in
+other directories.
+@end defun
+
+@example
+cd ~/scm/
+scm -rcompile -e'(compile-file "example.scm")'
+
+Starting to read example.scm
+
+Generic (slow) arithmetic assumed: 1.0e-3 found.
+
+** Pass 1 completed **
+** Pass 2 completed **
+** Pass 3 completed **
+** Pass 4 completed **
+** Pass 5 completed **
+** Pass 6 completed **
+
+C source file example.c is built.
+C header file example.h is built.
+
+These top level higher order procedures are not clonable (slow):
+(nonkeyword_make-promise map-streams generate-vector runge-kutta-4)
+These top level procedures create non-liftable closures (slow):
+(nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system)
+
+; Scheme (linux) script created by SLIB/batch Sun Apr  7 22:49:49 2002
+; ================ Write file with C defines
+(delete-file "scmflags.h")
+(call-with-output-file
+  "scmflags.h"
+  (lambda (fp)
+    (for-each
+      (lambda (string) (write-line string fp))
+      '("#define IMPLINIT \"Init@value{SCMVERSION}.scm\""
+        "#define BIGNUMS"
+        "#define FLOATS"
+        "#define ARRAYS"
+        "#define DLL"))))
+; ================ Compile C source files
+(system "gcc -O2 -fpic -c -I/usr/local/lib/scm/ example.c")
+(system "gcc -shared -o example.so example.o -lm -lc")
+(delete-file "example.o")
+; ================ Link C object files
+(delete-file "slibcat")
+
+Compilation finished at Sun Apr  7 22:49:50
+@end example
+
+@defun compile->executable exename name1.scm name2.scm @dots{}
+Compiles and links the HOBBIT translation of @var{name1}.scm,
+@var{name2}.scm, @dots{} to a SCM executable named @var{exename}.
+@var{name1}.scm must be in the current directory; @var{name2}.scm,
+@dots{} may be in other directories.
+@end defun
+
+@example
+cd ~/scm/
+scm -rcompile -e'(compile->executable "exscm" "example.scm")'
+
+Starting to read example.scm
+
+Generic (slow) arithmetic assumed: 1.0e-3 found.
+
+** Pass 1 completed **
+** Pass 2 completed **
+** Pass 3 completed **
+** Pass 4 completed **
+** Pass 5 completed **
+** Pass 6 completed **
+
+C source file example.c is built.
+C header file example.h is built.
+
+These top level higher order procedures are not clonable (slow):
+(nonkeyword_make-promise map-streams generate-vector runge-kutta-4)
+These top level procedures create non-liftable closures (slow):
+(nonkeyword_make-promise damped-oscillator map-streams scale-vector elementwise runge-kutta-4 integrate-system)
+
+; Scheme (linux) script created by SLIB/batch Sun Apr  7 22:46:31 2002
+; ================ Write file with C defines
+(delete-file "scmflags.h")
+(call-with-output-file
+  "scmflags.h"
+  (lambda (fp)
+    (for-each
+      (lambda (string) (write-line string fp))
+      '("#define IMPLINIT \"Init@value{SCMVERSION}.scm\""
+        "#define COMPILED_INITS init_example();"
+        "#define CCLO"
+        "#define FLOATS"))))
+; ================ Compile C source files
+(system "gcc -O2 -c continue.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c example.c scm.c")
+; ================ Link C object files
+(system "gcc -rdynamic -o exscm continue.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o example.o scm.o -L/usr/local/lib/scm/ -lm -lc")
+
+Compilation finished at Sun Apr  7 22:46:44
+@end example
+
+@emph{Note Bene:} @samp{#define CCLO} must be present in @file{scmfig.h}.
+
+In order to see calls to the C compiler and linker, do
+
+@example
+(verbose 3)
+@end example
+
+before calling these functions.
+
+
+@node Error Detection, Hobbit Options, Compiling And Linking, Compiling with Hobbit
+@section Error Detection
+
+Error detection during compilation is minimal.  In case your scheme code
+is syntactically incorrect, hobbit may crash with no sensible error
+messages or it may produce incorrect C code.
+
+Hobbit does not insert any type-checking code into the C output it
+produces.  Eg, if a hobbit-compiled program applies @samp{car} to a
+number, the program will probably crash with no sensible error messages.
+
+Thus it is strongly suggested to compile only throughly debugged
+scheme code.
+
+Alternatively, it is possible to compile all the primitives into
+calls to the SCM procedures doing type-checking.  Hobbit will do
+this if you tell it to assume that all the primitives may be
+redefined.  Put
+
+@example
+(define compile-all-proc-redefined #t)
+@end example
+
+anywhere in top level of your scheme code to achieve this.
+
+@emph{Note Bene:} The compiled code using
+
+@example
+(define compile-all-proc-redefined #t)
+@end example
+
+will typically be much slower than one produced without using
+
+@example
+(define compile-all-proc-redefined #t).
+@end example
+
+All errors caught by hobbit will generate an error message
+
+@example
+@group
+COMPILATION ERROR:
+@r{<description of the error>}
+@end group
+@end example
+
+and hobbit will immediately halt compilation.
+
+
+@node Hobbit Options, CC Optimizations, Error Detection, Compiling with Hobbit
+@section Hobbit Options
+
+@enumerate
+@item
+Selecting the type of arithmetics.
+
+By default hobbit assumes that only immediate (ie small, up to 30 bits)
+integers are used.  It will automatically assume general arithmetics in
+case it finds any non-immediate numbers like 1.2 or 10000000000000 or
+real-only procedures like @t{$sin} anywhere in the source.
+
+Another way to make Hobbit assume that generic arithmetic supported
+by SCM (ie exact and/or inexact reals, bignums) is also used, is to
+put the following line somewhere in your scheme source file:
+
+@example
+(define compile-allnumbers @var{t})
+@end example
+
+where @var{t} is arbitrary.
+
+In that case all the arithmetic primitives in all the given source
+files will be assumed to be generic.  This will make operations
+with immediate integers much slower.  You can use the special
+immediate-integer-only forms of arithmetic procedures to recover:
+
+@example
+@group
+%negative?  %number?    %>      %>=     %=      %<=     %<
+%positive?  %zero?      %eqv?   %+      %-      %*      %/
+@end group
+@end example
+
+See @ref{The Language Compiled}.
+
+@item
+Redefinition of procedures.
+
+By default hobbit assumes that neither primitives nor compiled
+procedures are redefined, neither before the compiled program is
+initialized, during its work or later via the interpreter.
+
+Hobbit checks the compiled source and whenever some variable bar is
+defined as a procedure, but is later redefined, or @t{set!}  is applied
+to bar, then hobbit assumes thas this particular variable bar is
+redefinable.  bar may be a primitive (eg @samp{car}) or a name of a
+compiled procedure.
+
+
+@emph{Note Bene:}
+According to the Report 4 it is @b{NOT} allowed to use scheme
+keywords as variables (you may redefine these as macros defined by
+defmacro, though):
+
+@example
+@group
+=> and begin case cond define delay do else if lambda
+let let letrec or quasiquote quote set! unquote unquote-splicing
+@end group
+@end example
+
+If you want to be able to redefine some procedures, eg. @samp{+} and
+@samp{baz}, then put both
+
+@example
+@group
+(set! + +)
+(set! baz baz)
+@end group
+@end example
+
+somewhere into your file.
+
+As a consequence hobbit will generate code for @samp{+} and @samp{baz}
+using the run-time values of these variables.  This is generally much
+slower than using non-redefined @samp{+} and @samp{baz} (especially for
+@samp{+}).
+
+If you want to be able to redefine all the procedures, both primitives
+(eg @samp{car}) and the compiled procedures, then put the following into
+the compiled file:
+
+@example
+(define compile-all-proc-redefined @var{t})
+@end example
+
+where @var{t} is arbitrary.
+
+If you want to be able to redefine all the compiled procedures, but not
+the scheme primitives, then put the following into the compiled file:
+
+@example
+(define compile-new-proc-redefined @var{t})
+@end example
+
+where @var{t} is arbitrary.
+
+Again, remember that redefinable procedures will be typically much
+slower than  non-redefinable procedures.
+
+
+@item
+Inlined variables and procedures.
+
+You may inline top-level-defined variables and procedures.
+Notice that inlining is DIFFERENT for variables and procedures!
+
+NEVER inline variables or procedures which are @t{set!} or redefined
+anywhere in you program: this will produce wrong code.
+
+@itemize @bullet
+@item
+You may declare certain top-level defined variables to be inlined.
+For example, if the following variable foo is declared to be inlined
+@end itemize
+
+@example
+(define foo 100)
+@end example
+
+then @samp{foo} will be everywhere replaced by @samp{100}.
+
+To declare some variables foo and bar to be inlined, put a following
+definition anywhere into your file:
+
+@example
+(define compile-inline-vars '(foo bar))
+@end example
+
+Usually it makes sense to inline only these variables whose value
+is either a small integer, character or a boolean.
+
+
+@emph{Note Bene:}
+Do not use this kind of inlining for inlining procedures!
+Use the following for procedures:
+
+@itemize @bullet
+@item
+You may declare certain procedures to be inlined.  For example, if
+the following foo is declared to be inlined
+@end itemize
+
+@example
+(define (foo x) (+ x 2))
+@end example
+
+then any call
+
+@example
+(foo @var{something})
+@end example
+
+will be replaced by
+
+@example
+(+ @var{something} 2)
+@end example
+
+Inlining is @b{NOT} safe for variable clashes -- in other words, it is
+not "hygienic".
+
+Inlining is @b{NOT} safe for recursive procedures -- if the set of
+inlined procedures contains either immediate or mutual (foo calling
+bar, bar calling foo) recursion, the compiler will not terminate.
+To turn off full inlining (harmful for recursive funs), change
+the definition of the *full-inlining-flag* in the section
+"compiler options" to the value #f instead of #t.
+
+To declare some procedures foo and bar to be inlined, put a following
+definition anywhere into your file:
+
+@example
+(define compile-inline '(foo bar))
+@end example
+
+@item
+Speeding up vectors:
+
+Put
+
+@example
+(define compile-stable-vectors '(baz foo))
+@end example
+
+into your file to declare that baz and foo are vector names defined once
+on the top level, and @t{set!} is never applied to them (@t{vector-set!}
+is, of course, allowed).  This speeds up vector reference to those
+vectors by precomputing their location.
+
+@item
+Speeding up and hiding certain global variables:
+
+Put
+
+@example
+(define compile-uninterned-variables '(bazvar foovar))
+@end example
+
+into your file to declare that bazvar and foovar are defined on the top
+level and they do always have an immediate value, ie a boolean,
+immediate (30-bit) integer or a character.  Then bazvar and foovar will
+@b{NOT} be accessible from the interpreter.  They'll be compiled directly
+into static C vars and used without an extra C *-operation prefixed to
+other global scheme variables.
+
+@item
+Intermediate files
+
+To see the output of compiler passes, change the following
+definition in @file{hobbit.scm}.
+
+@example
+(define *build-intermediate-files* #f)
+@end example
+
+to:
+
+@example
+(define *build-intermediate-files* #t)
+@end example
+
+@item
+Name clashes
+
+It may happen that several originally different scheme variable
+names are represented by one and the same C variable.  This will
+happen, for example, if you have separate variables a-1 and a_1.
+
+If such (or any other) name clashes occur you may
+need to change some control variables in the first sections
+of @file{hobbit.scm} (up to the section "global variable defs") or just
+rename some variables in your scheme program.
+
+@item
+Other options
+
+See various control variables in the first sections of @file{hobbit.scm}
+(up to section "global variable defs").
+@end enumerate
+
+
+
+@node CC Optimizations,  , Hobbit Options, Compiling with Hobbit
+@section CC Optimizations
+
+When using the C compiler to compile the C code output by hobbit, always
+use strong optimizations (eg. @samp{cc -xO3} for cc on Sun, @samp{gcc
+-O2} or @samp{gcc -O3} for gcc).  Hobbit does not attempt to do
+optimizations of the kind we anticipate from the C compiler, therefore
+it often makes a serious difference whether the C compiler is run with a
+strong optimization flag or not.
+
+For the final and fast version of your program you may want to first
+recompile the whole scm (scmlit for the version scm4e2) using the
+@samp{-DRECKLESS} flag suppressing error checking: the hobbit-compiled
+code uses some SCM primitives in the compiled files with the suffix .o,
+and a number of these primitives become faster when error checking is
+disabled by @samp{-DRECKLESS}.  Notice that hobbit never inserts error
+checking into the code it produces.
+
+
+
+@node The Language Compiled, Performance of Compiled Code, Compiling with Hobbit, Top
+@chapter The Language Compiled
+
+Calls to @code{load} or @code{require} occurring at the top level of a
+file being compiled are ignored.  Calls to @code{load} or @code{require}
+within a procedure are compiled to call (interpreted) @code{load} or
+@code{require} as appropriate.
+
+Several SCM and SLIB extensions to the Scheme report are recognized by
+hobbit as Scheme primitives.
+
+@menu
+* Macros::                      
+* SCM Primitive Procedures::    
+* SLIB Logical Procedures::     
+* Fast Integer Calculations::   
+* Force and Delay::             
+* Suggestions for writing fast code::  
+@end menu
+
+
+@node Macros, SCM Primitive Procedures, The Language Compiled, The Language Compiled
+@section Macros
+@c @heading The SCM macro-facility and the SCM extra syntactic form
+
+The Common-lisp style defmacro implemented in SCM is recognized and
+procedures defined by defmacro are expanded during compilation.
+
+@emph{Note Bene:} any macro used in a compiled file must be also defined
+in one of the compiled files.
+
+@samp{#.@var{<expression>}} is read as the object resulting from the
+evaluation of @var{<expression>}.  The calculation is performed during
+compile time.  Thus @var{<expression>} must not contain variables
+defined or @t{set!} in the compiled file.
+
+
+@node SCM Primitive Procedures, SLIB Logical Procedures, Macros, The Language Compiled
+@section SCM Primitive Procedures
+@c @heading The SCM extra primitives
+
+Real-only versions of transcedental procedures (warning: these
+procedures are not compiled directly into the corresponding C library
+procedures, but a combination of internal SCM procedures, guaranteeing exact
+correspondence with the SCM interpreter while hindering the speed):
+
+@example
+@group
+$sqrt $abs $exp $log $sin $cos $tan $asin $acos
+$atan $sinh $cosh $tanh $asinh $acosh $atanh $expt
+@end group
+@end example
+
+@emph{Note Bene:} These procedures are compiled to faster code than the
+corresponding generic versions @t{sqrt}, @t{abs}, @dots{} @t{expt}.
+
+A selection of other extra primitives in SCM is also recognized as
+primitives. eg. @t{get-internal-run-time}, @t{quit}, @t{abort},
+@t{restart}, @t{chdir}, @t{delete-file}, @t{rename-file}.
+
+
+@node SLIB Logical Procedures, Fast Integer Calculations, SCM Primitive Procedures, The Language Compiled
+@section SLIB Logical Procedures
+@c @heading Bitwise logical procedures from the scheme library
+
+The following bitwise procedures in the scheme library file
+@file{logical.scm} are compiled directly to fast C operations on
+immediate integers (small 30-bit integers) (Scheme library funs in the
+upper row, C ops below):
+
+@example
+@group
+   logand logior logxor lognot logsleft logsright
+      &      |     ^      ~       <<        >>
+@end group
+@end example
+
+The following alternative names @t{logical:logand}, @t{logical:logior},
+@t{logical:logxor}, @t{logical:lognot}, @t{ash}, @t{logical:ash} are compiled for the
+generic case, not immediate-integers-only and are thus much slower.
+
+Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in
+the the library file @file{logical.scm:} the universal procedure @t{ash}
+is instead.  Procedures @t{ash}, @t{logcount}, @t{integer-length},
+@t{integer-expt}, @t{bit-extract}, @t{ipow-by-squaring},
+@t{logical:ash}, @t{logical:logcount}, @t{logical:integer-length},
+@t{logical:integer-expt}, @t{logical:bit-extract},
+@t{logical:ipow-by-squaring}, in @file{logical.scm} are not primtives
+and they are all compiled into calls to interpreted code.
+
+@t{logsleft} and @t{logsright} are defined for non-compiled use in the
+file @file{scmhob.scm} included in the SCM distribution.
+
+
+@node Fast Integer Calculations, Force and Delay, SLIB Logical Procedures, The Language Compiled
+@section Fast Integer Calculations
+@c @heading Immediate (fast) arithmetics
+
+The following primitives are for immediate (30-bit) integer-only
+arithmetics.  The are compiled directly into the corresponding C
+operations plus some bitshifts if necessary.  They are good for speed in
+case the compiled program uses BOTH generic arithmetics (reals, bignums)
+and immediate (30-bit) integer arithmetics.  These procedures are much
+faster than corresponding generic procedures taking also reals and
+bignums.  There is no point in using these unless the program as a whole
+is compiled using generic arithmetics, since otherwise all the
+arithmetics procedures are compiled directly into corresponding C
+operations anyway.
+
+@emph{Note Bene:} These primitives are @b{NOT} defined in SCM or its
+libraries.  For non-compiled use they are defined in the file
+@file{scmhob.scm} included in the SCM distribution.
+
+@example
+@group
+%negative?  %number?    %>      %>=     %=      %<=     %<
+%positive?  %zero?      %eqv?   %+      %-      %*      %/
+@end group
+@end example
+
+@node Force and Delay, Suggestions for writing fast code, Fast Integer Calculations, The Language Compiled
+@section Force and Delay
+
+The nonessential procedure @code{force} and syntax @code{delay} are
+implemented exactly as suggested in the report 4.  This implementation
+deviates internally from the implementation of @code{force} and
+@code{delay} in the SCM interpeter, thus it is incorrect to pass a
+promise created by @code{delay} in the compiled code to the @code{force}
+used by interpreter, and vice-versa for the promises created by the
+interpreter.
+
+
+
+@node Suggestions for writing fast code,  , Force and Delay, The Language Compiled
+@section Suggestions for writing fast code
+
+The following suggestions may help you to write well-optimizable and
+fast code for the hobbit-scm combination.  Roughly speaking, the main
+points are:
+
+@itemize
+@item
+minimizing consing and creation of new vectors and strings
+in speed-critical parts,
+
+@item
+minimizing the use of generic (non-integer) arithmetics
+in speed-critical parts,
+
+@item
+minimizing the usage of procedures as first-class
+objects (very roughly speaking, explicit lambda-terms
+and call/cc) in speed-critical parts,
+
+@item
+using special options and fast-compiled primitives of the compiler.
+@end itemize
+
+Here come the details.
+
+@enumerate
+@item
+Immediate arithmetics (ie using small, up to 30 bits integers) is much
+faster than generic (reals and bignums) arithmetics.  If you have to use
+generic arithmetic in your program, then try to use special immediate
+arithmetics operations @code{%=}, @code{%<=}, @code{%+}, @code{%*},
+@dots{} for speed-critical parts of the program whenever possible.
+
+Also, if you use bitwise logical operations, try to use the
+immediate-integer-only versions
+
+@example
+logand logior logxor lognot logsleft logsright
+@end example
+
+and not @code{logical:logand} or @code{ash}, for example.
+
+@item
+Due to its inner stack-based architecture, the generic (not escape-only)
+continuations are very slow in SCM.  Thus they are also slow in
+compiled code.  Try to avoid continuations  (calls to the procedure
+call-with-current-continuation and calls to the  continuations it
+produces) in speed-critical parts.
+
+@item
+In speed-critical parts of your program try to avoid using procedures
+which are redefined or defined by @t{set!}:
+
+@example
+@group
+(set! bar +)
+(set! f (lambda (x) (if (zero? x) 1 (* x (f (- x 1))))))
+@end group
+@end example
+
+anywhere in the compiled program.  Avoid using compiler flags
+(@pxref{Hobbit Options}):
+
+@example
+@group
+(define compile-all-proc-redefined @var{t})
+(define compile-new-proc-redefined @var{t})
+@end group
+@end example
+
+@item
+Do not use complicated higher-order procedures in speed-critical
+parts.  By @dfn{complicated} we mean @dfn{not clonable}, where clonability
+is defined in the following way (@emph{Note Bene:} the primitives
+@samp{map} and @samp{for-each} are considered clonable and do not
+inflict a speed penalty).
+
+A higher-order procedure (HOP for short) is defined as a procedure
+with some of its formal arguments occuring in the procedure body in
+a function position, that is, as a first element of a list.  Such
+an argument is called a @dfn{higher-order argument}.
+
+A HOP @samp{bar} is clonable iff it satisfies the following four
+conditions:
+
+@enumerate
+@item
+@samp{bar} is defined as
+
+@example
+(define bar (lambda @dots{}))
+@end example
+
+or
+
+@example
+(define (bar @dots{}) @dots{})
+@end example
+
+on top level and bar is not redefined anywhere.
+
+@item
+the name @samp{bar} occurs inside the body of bar only in a function position
+and not inside an internal lambda-term.
+
+@item
+Let f be a higher-order argument of bar.
+Any occurrence of f in bar has one of the following two forms:
+
+@itemize @bullet
+@item
+f occurs in a function position,
+@item
+f is passed as an argument to bar and in the call it occurs in the same
+position as in the argument list.
+@end itemize
+
+@item
+Let f be a higher-order argument of bar.  f does not occur inside a
+lambda-term occurring in bar.
+
+Examples:
+
+If @samp{member-if} is defined on top level and is not redefined
+anywhere, then @samp{member-if} is a clonable HOP:
+
+@example
+@group
+(define (member-if fn lst)
+   (if (fn (car lst))
+       lst
+       (member-if fn (cdr lst)) ))
+@end group
+@end example
+
+member-if-not is not a clonable HOP (fn occurs in a lambdaterm):
+
+@example
+@group
+(define (member-if-not fn lst)
+  (member (lambda (x) (not (fn x))) lst) )
+@end group
+@end example
+
+show-f is not a clonable HOP (fn occurs in a non-function position
+in (display fn)):
+
+@example
+@group
+(define (show-f fn x)
+    (set! x (fn x))
+    (display fn)
+    x)
+@end group
+@end example
+
+@item
+In speed-critical parts avoid using procedures which return procedures.
+
+Eg, a procedure
+
+@example
+@group
+(define plus
+  (lambda (x)
+     (lambda (y) (+ y x)) ))
+@end group
+@end example
+
+returns a procedure.
+
+@item
+A generalisation of the previous case 5:
+
+In speed-critical parts avoid using lambda-terms except in non-@t{set!}
+function definitions like
+
+@example
+@group
+(define foo (lambda @dots{})),
+(let ((x 1) (f (lambda @dots{}))) @dots{})
+(let* ((x 1) (f (lambda @dots{}))) @dots{})
+(let name ((x 1) (f (lambda @dots{}))) @dots{})
+(letrec ((f (lambda @dots{})) (g (lambda @dots{}))) @dots{})
+@end group
+@end example
+
+or as arguments to clonable HOP-s or primitives @t{map} and
+@t{for-each}, like
+
+@example
+@group
+(let ((x 0)) (map (lambda (y) (set! x (+ 1 x)) (cons x y)) @var{list}))
+(member-if (lambda (x) (< x 0)) @var{list})
+@end group
+@end example
+
+where member-if is a clonable HOP.
+
+Also, avoid using variables with a procedural value anywhere
+except in a function position (first element of a list) or
+as an argument to a clonable HOP, @t{map} or @t{for-each}.
+
+Lambda-terms conforming to the current point are said to be liftable.
+
+Examples:
+
+@example
+(define (bar x) (let ((f car)) (f (f x))))
+@end example
+
+has @samp{car} in a non-function and non-HOP-argument position in
+@code{(f car)}, thus it is slower than
+
+@example
+(define (bar x) (let ((f 1)) (car (car x))))
+@end example
+
+Similarly,
+
+@example
+@group
+(define (bar y z w)
+  (let ((f (lambda (x) (+ x y))))
+     (set! w f)
+     (cons (f (car z))
+           (map f z) )))
+@end group
+@end example
+
+has @samp{f} occurring in a non-function position in @code{(set! w f)},
+thus the lambda-term @code{(lambda (x) (+ x y))} is not liftable and the
+upper @samp{bar} is thus slower than the following equivalent @samp{bar}
+with a liftable inner lambda-term:
+
+@example
+@group
+(define (bar y z w)
+  (let ((f (lambda (x) (+ x y))))
+     (set! w 0)
+     (cons (f (car z))
+           (map f z) )))
+@end group
+@end example
+
+Using a procedure bar defined as
+
+@example
+(define bar (let ((x 1)) (lambda (y) (set! x y) (+ x y))))
+@end example
+
+is slower than using a procedure bar defined as
+
+@example
+@group
+(define *bar-x* 1)
+(define bar (lambda (y) (set! *bar-x* y) (+ *bar-x* y)))
+@end group
+@end example
+
+since the former definition contains a non-liftable lambda-term.
+
+@item
+Try to minimize the amount of consing in the speed-critical program
+fragments, that is, a number of applications of cons, list, @t{map},
+quasiquote (`) and vector->list during the time program is running.
+@samp{cons} (called also by @samp{list}, @samp{map} and
+@samp{quasiquote}) is translated into a C call to an internal cons
+procedure of the SCM interpreter.  Excessive consing also means that the
+garbage collection happens more often.  Do @code{(verbose 3)} to see the
+amount of time used by garbage collection while your program is running.
+
+Try to minimize the amount of creating new vectors, strings and symbols
+in the speed-critical program frgaments, that is, a number of
+applications of @t{make-vector}, @t{vector}, @t{list->vector},
+@t{make-string}, @t{string-append}, *@t{->string}, @t{string->symbol}.
+Creating such objects takes typically much more time than consing.
+
+@item
+The Scheme iteration construction @samp{do} is compiled directly into
+the C iteration construction @samp{for}.  We can expect that the C compiler
+has some knowledge about @samp{for} in the optimization stage, thus it is
+probably faster to use @samp{do} for iteration than non-mutual tailrecursion
+(which is recognized by hobbit as such and is compiled into a jump to a
+beginning of a procedure) and certainly much faster than
+non-tail-recursion or mutual tailrecursion (the latter is not recognized
+by hobbit as such).
+
+@item
+Declare small nonrecursive programs which do not contain
+let-s or lambdaterms as being inlinable.
+
+Declare globally defined variables which are never @t{set!} or redefined
+and whose value is a small integer, character or a boolean,
+as being inlinable.  @xref{Hobbit Options}.
+
+@item
+If possible, declare vectors as being stable.
+@xref{Hobbit Options, Speeding up vectors}.
+This gives a minor improvement in speed.
+
+@item
+If possible, declare critical global vars as being uninterned.
+@xref{Hobbit Options, Speeding up and hiding certain global variables}.
+This gives a minor improvement in speed.  Declare the global variables
+which are never @t{set!} and have an (unchanged) numeric or boolean
+value as being inlined.  @xref{Hobbit Options}.
+@end enumerate
+
+In addition, take the following into account:
+
+@itemize @bullet
+@item
+When using the C compiler to compile the C code output by hobbit, always
+use strong optimizations (eg. @samp{cc -xO3} for cc on Sun, @samp{gcc
+-O2} or @samp{gcc -O3} for gcc).  Hobbit does not attempt to do
+optimizations of the kind we anticipate from the C compiler, therefore
+it often makes a big difference if the C compiler is run with a strong
+optimization flag or not.
+
+@item
+hobbit does not give proper tailrecursion behaviour for mutual
+tailrecursion (foo calling bar, bar calling foo tailrecursively).
+
+Hobbit guarantees proper tailrecursive behaviour for non-mutual
+tailrecursion (foo calling foo tailrecursively), provided that
+foo is not redefined anywhere and that foo is not a local function which
+occurs also in a non-function and non-clonable-HOP-argument position
+(i.e. cases 3 and 6 above).
+@end itemize
+@end enumerate
+
+
+
+@node Performance of Compiled Code, Principles of Compilation, The Language Compiled, Top
+@chapter Performance of Compiled Code
+
+
+@menu
+* Gain in Speed::               
+* Benchmarks::                  
+* Benchmark Sources::           
+@end menu
+
+@node Gain in Speed, Benchmarks, Performance of Compiled Code, Performance of Compiled Code
+@section Gain in Speed
+
+The author has so far compiled and tested a number of large programs
+(theorem provers for various logics and hobbit itself).
+
+The speedup for the provers was between 25 and 40 times for various
+provable formulas.  Comparison was made between the provers being
+interpreted and compiled with @samp{gcc -O2 -DRECKLESS} on Sparcstation
+ELC in both cases.
+
+The provers were written with care to make the compiled version run fast.
+They do not perform excessive consing and they perform very little
+arithmetic.
+
+According to experiments made by A. Jaffer, the compiled form of the
+example program @file{pi.scm} was approximately 11 times faster than the
+interpreted form.
+
+As a comparison, his hand-coded C program for the same algorithm of
+computing pi was about 12 times faster than the interpreted form.
+@file{pi.scm} spends most of of its time in immediate arithmetics,
+@t{vector-ref} and @t{vector-set!}.
+
+P. Kelloma"ki has reported a 20-fold speedup for his generic scheme
+debugger.  T. Moore has reported a 16-fold speedup for a large gate-level
+IC optimizer.
+
+Self-compilation speeds Hobbit up only ca 10 times.
+
+However, there are examples where the code compiled by hobbit
+runs actually slower than the same code running under interpreter:
+this may happen in case the speed of the code relies on non-liftable
+closures and proper mutual tailrecursion.  See for example the
+closure-intensive benchmark CPSTAK in the following table.
+
+@page
+@node Benchmarks, Benchmark Sources, Gain in Speed, Performance of Compiled Code
+@section Benchmarks
+
+We will present a table with the performance of three scheme systems on
+a number of benchmarks: interpreted SCM, byte-compiled VSCM and
+hobbit-compiled code.  The upper 13 benchmarks of the table are the
+famous Gabriel benchmarks (originally written for lisp) modified for
+scheme by Will Clinger.  The lower five benchmarks of the table are
+proposed by other people.  @dfn{Selfcompile} is the self-compile time
+of Hobbit.
+
+
+Hobbit performs well on most of the benchmarks except
+CPSTAK and CTAK: CPSTAK is a closure-intensive tailrecursive
+benchmark and CTAK is a continuations-intensive benchmark.
+Hobbit performs extremely well on these benchmarks which essentially
+satisfy the criterias for well-optimizable code outlined in the
+section 6 above.
+
+FFT is real-arithmetic-intensive.
+
+All times are in seconds.
+
+SCM 4c0(U) and 1.1.5*(U) (the latter is the newest version of VSCM)
+are compiled and run by Matthias Blume on a DecStation 5000 (Ultrix).
+VSCM is a bytecode-compiler using continuation-passing style, and is well
+optimized for continuations and closures.
+
+SCM 4e2(S) and Hobbit4b(S) compiled (with @samp{cc -xO3}) and run by
+Tanel Tammet on a Sun SS10 (lips.cs.chalmers.se).  Hobbit is a
+Scheme-to-C compiler for SCM, the code it produces does not do any
+checking.  SCM and hobbit are not optimized for continuations.  Hobbit
+is not optimized for closures and proper mutual tailrecursion.
+
+SCM and Hobbit benchmarks were run giving ca 8 MB of free heap space
+before each test.
+
+@example
+@group
+Benchmark       |SCM 4c0(U) 1.1.5*(U)| SCM 4e2(S)  Hobbit4b(S)
+----------------|------------------------------------------------
+Deriv           | 3.40      3.86     |  2.9            0.18
+Div-iter        | 3.45      2.12     |  2.6            0.083
+Div-rec         | 3.45      2.55     |  3.5            0.42
+TAK             | 1.81      1.71     |  1.4            0.018
+TAKL            |14.50     11.32     | 13.8(1.8 in gc) 0.13
+TAKR            | 2.20      1.64     |  1.7 1.5        0.018
+Destruct        | ?          ?       |  7.4(1.8 in gc) 0.18
+Boyer           | ?          ?       | 27.(3.8 in gc)  1.9
+CPSTAK          | 2.72      2.64     |  2.0 1.92       3.46(2.83 in gc)
+CTAK            |31.0       4.11     | memory          memory
+CTAK(7 6 1)     | ?          ?       |  0.83           0.74
+FFT             |12.45     15.7      | 11.4 10.8       1.0
+Puzzle          | 0.28      0.41     |  0.46(0.22 gc)  0.03
+----------------------------------------------------------------
+(recfib 25)     | ?          ?       |  4.1            0.079
+(recfib 30)     | ?          ?       | 55. (10.in gc)  0.87
+(pi 300 3)      | ?          ?       |  7.4            0.46
+(hanoi 15)      | ?          ?       |  0.68           0.007
+(hanoi 20)      | ?          ?       | 31. (9. in gc)  0.2
+----------------------------------------------------------------
+@end group
+@end example
+
+@page
+@node Benchmark Sources,  , Benchmarks, Performance of Compiled Code
+@section Benchmark Sources
+@subheading A selection of (smaller) benchmark sources
+
+@menu
+* Destruct::                    
+* Recfib::                      
+* div-iter and div-rec::        
+* Hanoi::                       
+* Tak::                         
+* Ctak::                        
+* Takl::                        
+* Cpstak::                      
+* Pi::                          
+@end menu
+
+@node Destruct, Recfib, Benchmark Sources, Benchmark Sources
+@subsection Destruct
+
+@example
+@group
+;;;; Destructive operation benchmark
+(define (destructive n m)
+  (let ((l (do ((i 10 (- i 1))
+                (a '() (cons '() a)))
+               ((= i 0) a))))
+    (do ((i n (- i 1)))
+        ((= i 0))
+      (if (null? (car l))
+          (do ((l l (cdr l)))
+              ((null? l))
+            (or (car l) (set-car! l (cons '() '())))
+            (append! (car l) (do ((j m (- j 1))
+                                  (a '() (cons '() a)))
+                                 ((= j 0) a))))
+          (do ((l1 l (cdr l1))
+               (l2 (cdr l) (cdr l2)))
+              ((null? l2))
+            (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
+                           (a (car l2) (cdr a)))
+                          ((zero? j) a)
+                        (set-car! a i))
+                      (let ((n (quotient (length (car l1)) 2)))
+                        (cond ((= n 0) (set-car! l1 '()) (car l1))
+                              (else (do ((j n (- j 1))
+                                         (a (car l1) (cdr a)))
+                                        ((= j 1)
+                                         (let ((x (cdr a)))
+                                           (set-cdr! a '()) x))
+                                      (set-car! a i)))))))))))
+;; call:  (destructive 600 50)
+@end group
+@end example
+
+@need 1500
+@node Recfib, div-iter and div-rec, Destruct, Benchmark Sources
+@subsection Recfib
+
+@example
+@group
+(define (recfib x)
+  (if (< x 2)
+      x
+      (+ (recfib (- x 1))
+         (recfib (- x 2)))))
+@end group
+@end example
+
+@need 4000
+@node div-iter and div-rec, Hanoi, Recfib, Benchmark Sources
+@subsection div-iter and div-rec
+
+@example
+@group
+;;;; Recursive and iterative benchmark divides by 2 using lists of ()'s.
+(define (create-n n)
+  (do ((n n (- n 1))
+       (a '() (cons '() a)))
+      ((= n 0) a)))
+(define *ll* (create-n 200))
+(define (iterative-div2 l)
+  (do ((l l (cddr l))
+       (a '() (cons (car l) a)))
+      ((null? l) a)))
+(define (recursive-div2 l)
+  (cond ((null? l) '())
+        (else (cons (car l) (recursive-div2 (cddr l))))))
+(define (test-1 l)
+  (do ((i 300 (- i 1))) ((= i 0))
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)
+    (iterative-div2 l)))
+(define (test-2 l)
+  (do ((i 300 (- i 1))) ((= i 0))
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)
+    (recursive-div2 l)))
+;; for the iterative test call: (test-1 *ll*)
+;; for the recursive test call: (test-2 *ll*)
+@end group
+@end example
+
+@need 1000
+@node Hanoi, Tak, div-iter and div-rec, Benchmark Sources
+@subsection Hanoi
+
+@example
+@group
+;;; C optimiser should be able to remove the first recursive call to
+;;; move-them.  But Solaris 2.4 cc, gcc 2.5.8, and hobbit don't.
+(define (hanoi n)
+  (letrec ((move-them
+            (lambda (n from to helper)
+              (if (> n 1)
+                  (begin
+                    (move-them (- n 1) from helper to)
+                    (move-them (- n 1) helper to from))))))
+    (move-them n 0 1 2)))
+@end group
+@end example
+
+@page
+@node Tak, Ctak, Hanoi, Benchmark Sources
+@subsection Tak
+
+@example
+@group
+;;;; A vanilla version of the TAKeuchi function
+(define (tak x y z)
+  (if (not (< y x))
+      z
+      (tak (tak (- x 1) y z)
+           (tak (- y 1) z x)
+           (tak (- z 1) x y))))
+;; call: (tak 18 12 6)
+@end group
+@end example
+
+@need 2000
+@node Ctak, Takl, Tak, Benchmark Sources
+@subsection Ctak
+
+@example
+@group
+;;;; A version of the TAK function that uses continuations
+(define (ctak x y z)
+  (call-with-current-continuation
+   (lambda (k)
+     (ctak-aux k x y z))))
+
+(define (ctak-aux k x y z)
+  (cond ((not (< y x)) (k z))
+        (else (call-with-current-continuation
+               (ctak-aux
+                k
+                (call-with-current-continuation
+                 (lambda (k) (ctak-aux k (- x 1) y z)))
+                (call-with-current-continuation
+                 (lambda (k) (ctak-aux k (- y 1) z x)))
+                (call-with-current-continuation
+                 (lambda (k) (ctak-aux k (- z 1) x y))))))))
+
+(define (id x) x)
+
+(define (mb-test r x y z)
+  (if (zero? r)
+      (ctak x y z)
+      (id (mb-test (- r 1) x y z))))
+;;; call: (ctak 18 12 6)
+@end group
+@end example
+
+@need 2000
+@node Takl, Cpstak, Ctak, Benchmark Sources
+@subsection Takl
+
+@example
+@group
+;;;; The TAKeuchi function using lists as counters.
+(define (listn n)
+  (if (not (= 0 n))
+      (cons n (listn (- n 1)))
+      '()))
+
+(define l18 (listn 18))
+(define l12 (listn 12))
+(define l6 (listn 6))
+
+(define (mas x y z)
+  (if (not (shorterp y x))
+      z
+      (mas (mas (cdr x) y z)
+           (mas (cdr y) z x)
+           (mas (cdr z) x y))))
+
+(define (shorterp x y)
+  (and (pair? y) (or (null? x) (shorterp (cdr x) (cdr y)))))
+;; call: (mas l18 l12 l6)
+@end group
+@end example
+
+@need 2000
+@node Cpstak, Pi, Takl, Benchmark Sources
+@subsection Cpstak
+
+@example
+@group
+;;;; A continuation-passing version of the TAK benchmark.
+(define (cpstak x y z)
+  (define (tak x y z k)
+    (if (not (< y x))
+        (k z)
+        (tak (- x 1)
+             y
+             z
+             (lambda (v1)
+               (tak (- y 1)
+                    z
+                    x
+                    (lambda (v2)
+                      (tak (- z 1)
+                           x
+                           y
+                           (lambda (v3)
+                             (tak v1 v2 v3 k)))))))))
+  (tak x y z (lambda (a) a)))
+;;; call: (cpstak 18 12 6)
+@end group
+@end example
+
+@need 4000
+@node Pi,  , Cpstak, Benchmark Sources
+@subsection Pi
+
+@example
+@group
+(define (pi n  . args)
+      (let* ((d (car args))
+             (r (do ((s 1 (* 10 s))
+                     (i 0 (+ 1 i)))
+                    ((>= i d) 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)))
+@end group
+@end example
+
+
+@node Principles of Compilation, About Hobbit, Performance of Compiled Code, Top
+@chapter Principles of Compilation
+
+@menu
+* Macro-Expansion and Analysis::  Pass 1
+* Building Closures::           Pass 2
+* Lambda-lifting::              Pass 3
+* Statement-lifting::           Pass 4
+* Higher-order Arglists::       Pass 5
+* Typing and Constants::        Pass 6
+@end menu
+
+@node Macro-Expansion and Analysis, Building Closures, Principles of Compilation, Principles of Compilation
+@section Expansion and Analysis
+
+
+@enumerate
+@item
+Macros defined by defmacro and all the quasiquotes
+are expanded and compiled into equivalent form without macros
+and quasiquotes.
+
+For example, `(a , x) will be converted to (cons 'a (cons x '())).
+
+@item
+Define-s with the nonessential syntax like
+
+@example
+(define (foo x) @dots{})
+@end example
+
+are converted to @t{define}s with the essential syntax
+
+@example
+(define foo (lambda (x) @dots{}))
+@end example
+
+Non-top-level @t{define}s are converted into equivalent
+@t{letrec}-s.
+
+@item
+Variables are renamed to avoid name clashes, so that any local
+variable may have a whole procedure as its scope.  This renaming
+also converts let-s to let*-s.  Variables which do not introduce
+potential name clashes are not renamed.  For example,
+
+@example
+@group
+(define (foo x y)
+   (let ((x y)
+         (z x))
+     (let* ((x (+ z x)))
+       x)))
+@end group
+@end example
+
+is converted to
+
+@example
+@group
+(define foo
+  (lambda (x y)
+    (let* ((x__1 y)
+           (z x)
+           (x__2 (+ z x__1)))
+       x__2)))
+@end group
+@end example
+
+@item
+In case the set of procedures defined in one @t{letrec} is actually not
+wholly mutually recursive (eg, f1 calls f2, but f2 does not call f1, or
+there are three procedures, f1, f2, f3 so that f1 and f2 are mutually
+recursive but f3 is not called from f1 or f2 and it does not call them,
+etc), it is possible to minimize the number of additional variables
+passed to procedures.
+
+Thus @t{letrec}-s are split into ordered chunks using dependency
+analysis and topological sorting, to reduce the number of mutually
+passed variables.  Wherever possible, @t{letrec}-s are replaced by
+@t{let*}-s inside these chunks.
+
+
+@item
+Normalization is performed.  This converts a majority of scheme
+control procedures like cond, case, or, and into equivalent
+terms using a small set of primitives.  New variables may be
+introduced in this phase.
+
+In case a procedure like or or and occurs in the place where its value
+is treated as a boolean (eg. first argument of if), it is converted
+into an analogous boolean-returning procedure, which will finally
+be represented by an analogous C procedure (eg. || or &&).
+
+Associative procedures are converted into structures of corresponding
+nonassociative procedures.  List is converted to a structure of cons-s.
+
+Map and @t{for-each} with more than two arguments are converted into an
+equivalent do-cycle.  @t{map}-s and @t{for-each}-s with two arguments are
+treated as if they were defined in the compiled file -- the definitions
+@t{map1} and @t{for-each1} are automatically included, if needed.
+
+There is an option in @file{hobbit.scm} to make all @t{map}-s and
+@t{for-each}-s be converted into equivalent do-loops, avoiding the use
+of @t{map1} and/or @t{for-each1} altogether.
+
+
+@item
+Code is analysed for determining which primitive names and
+compiled procedure names are assumed to be redefinable.
+
+@item
+Analysing HOP clonability: hobbit will find a list of clonable
+HOP-s with information about higher-order arguments.
+
+Criterias for HOP clonability are given in the section 6.4.
+
+
+@item
+Analysis of liftability: hobbit will determine which lambda-terms
+have to be built as real closures (implemented as a vector where the
+first element is a pointer to a function and the rest contain values
+of environment variables or environment blocks of surrounding code)
+and which lambda-terms are liftable.
+
+Liftability analysis follows the criterias given in section 6.5 and
+6.6.
+@end enumerate
+
+
+@node Building Closures, Lambda-lifting, Macro-Expansion and Analysis, Principles of Compilation
+@section Building Closures
+
+
+Here Hobbit produces code for creating real closures for all the
+lambda-terms which are not marked as being liftable by the previous
+liftability analysis.
+
+Global variables (eg x-glob) are translated as pointers (locations) to
+SCM objects and used via a fetch: *x_glob (or a fetch
+macro GLOBAL(x-glob) which translates to *x_glob).
+
+While producing closures hobbit tries to minimize the indirection
+levels necessary.  Generally a local variable x may have to be translated
+to an element of a vector of local variables built in the procedure
+creating x.  If x occurs in a non-liftable closure, the whole vector
+of local variables is passed to a closure.
+
+Such a translation using a local vector will only take place if either x
+is @t{set!} inside a non-liftable lambda-term or x is a name of a
+recursively defined non-liftable function, and the definition of x is
+irregular.  The definition of x is irregular if x is given the
+non-liftable recursive value @var{t} by extra computation, eg as
+
+@example
+(set! x (let ((u 1)) (lambda (y) (display u) (x (+ u 1)))))
+@end example
+
+and not as a simple lambdaterm:
+
+@example
+(set! x (lambda (y) (display x) (x (+ y 1))))
+@end example
+
+In all the other cases a local scheme variable x is translated
+directly to a local C variable x having the type SCM (a 32-bit
+integer).  If such an x occurs in a non-liftable closure, then
+only its value is passed to a closure via the closure-vector.
+In case the directly-translated variable x is passed to a liftable
+lambda-term where it is @t{set!}, then x is passed indirectly by
+using its address &x.  In the lifted lambda-term it is then accessed via *.
+
+If all the variables x1, @dots{}, xn created in a procedure can be
+translated directly as C variables, then the procedure does not create a
+special vector for (a subset of) local variables.
+
+An application (foo @dots{}) is generally translated to C by an internal
+apply of the SCM interpreter:
+apply(GLOBAL(foo), @dots{}).  Using an internal apply is much slower than
+using direct a C function call, since:
+
+@itemize @bullet
+@item
+there is an extra fetch by GLOBAL(foo),
+@item
+internal apply performs some computations,
+@item
+the arguments of foo are passed as a list constructed during
+    application: that is, there is a lot of expensive consing every
+    time foo is applied via an internal apply.
+@end itemize
+
+However, in case foo is either a name of a non-redefined primitive or a
+name of a non-redefined liftable procedure, the application is
+translated to C directly without the extra layer of calling apply:
+foo(@dots{}).
+
+Sometimes lambda-lifting generates the case that some variable
+x is accessed not directly, but by *x.  See the next section.
+
+Undefined procedures are assumed to be defined via interpreter
+and are called using an internal apply.
+
+@node Lambda-lifting, Statement-lifting, Building Closures, Principles of Compilation
+@section Lambda-lifting
+
+
+When this pass starts, all the real (nonliftable) closures have been
+translated to closure-creating code.  The remaining lambda-terms
+are all liftable.
+
+Lambda-lifting is performed.  That is, all procedures defined inside
+some other procedure (eg. in @t{letrec}) and unnamed lambda-terms are
+made top-level procedure definitions.  Any N variables not bound in such
+procedures which were bound in the surrounding procedure are given as
+extra N first parameters of the procedure, and whenever the procedure is
+called, the values of these variables are given as extra N first
+arguments.
+
+For example:
+
+@example
+@group
+(define foo
+  (lambda (x y)
+     (letrec ((bar (lambda (u) (+ u x))))
+        (bar y) )))
+@end group
+@end example
+
+is converted to
+
+@example
+@group
+(define foo
+  (lambda (x y)
+    (foo-fn1 x y) ))
+
+(define foo-fn1
+  (lambda (x u)
+    (+ u x) ))
+@end group
+@end example
+
+The case of mutually recursive definitions in @t{letrec} needs special
+treatment -- all free variables in mutually recursive funs have, in
+general, to be passed to each of those funs.  For example, in
+
+@example
+@group
+(define (foo x y z i)
+  (letrec ((f1 (lambda (u) (if x (+ (f2 u) 1))))
+           (f2 (lambda (v) (if (zero? v) 1 (f1 z)))) )
+    (f2 i) ))
+@end group
+@end example
+
+the procedure f1 contains a free variable x and the procedure f2
+contains a free variable z.  Lambda-lifted f1 and f2 must
+each get both of these variables:
+
+@example
+@group
+(define (foo x y z i)
+   (foo-fn2 x z i) )
+
+(define foo-fn1
+  (lambda (x z u) (if x (+ (foo-fn2 x z u) 1))) )
+
+(define foo-fn2
+  (lambda (x z v) (if (zero? v) 1 (foo-fn1 x z z))) )
+@end group
+@end example
+
+Recall that hobbit has already done dependency analysis and has
+split the original @t{letrec} into smaller chunks according to this
+analysis: see pass 1.
+
+Whenever the value of some free variable is modified by @t{set!} in
+the procedure, this variable is passed by reference instead.
+This is not directly possible in scheme, but it is possible in C.
+
+@example
+@group
+(define foo
+  (lambda (x y z)
+     (letrec ((bar (lambda (u) (set! z (+ u x z)))))
+        (bar y)
+        z)))
+@end group
+@end example
+
+is converted to incorrect scheme:
+
+@example
+@group
+(define foo
+  (lambda (x y z)
+    (foo-fn1 x (**c-adr** z) y)
+    z))
+
+(define foo-fn1
+  (lambda (x (**c-adr** z) u)
+    (set! (**c-fetch** z) (+ u x (**c-fetch** z))) ))
+@end group
+@end example
+
+The last two will finally be compiled into correct C as:
+
+@example
+@group
+SCM foo(x, y, z)
+SCM x, y, z;
+@{
+  foo_fn1(x, &z, y);
+  return z;
+@}
+
+SCM foo_fn1(x, z, u)
+SCM x, u;
+SCM *z;
+@{
+  return (*z =  (u + x) + *z);
+@}
+@end group
+@end example
+
+
+
+@node Statement-lifting, Higher-order Arglists, Lambda-lifting, Principles of Compilation
+@section Statement-lifting
+
+As the scheme do-construction is compiled into C for, but for cannot
+occur in all places in C (it is a statement), then if the do in a
+scheme procedure occurs in a place which will not be a statement
+in C, the whole do-term is lifted out into a new top-level
+procedure analogously to lambda-lifting.  Any statement-lifted
+parts of some procedure foo are called foo_aux@var{n}, where @var{n}
+is a number.
+
+The special C-ish procedure **return** is pushed into a scheme term as far
+as possible to extend the scope of statements in the resulting
+C program.  For example,
+
+@example
+@group
+(define foo
+  (lambda (x y)
+      (if x (+ 1 y) (+ 2 y)) ))
+@end group
+@end example
+
+is converted to
+
+@example
+@group
+(define foo
+   (lambda (x y)
+     (if x (**return** (+ 1 y)) (**return** (+ 2 y))) ))
+@end group
+@end example
+
+Immediate tailrecursion (foo calling foo tailrecursively) is
+recognized and converted into an assignment of new values to args and
+a jump to the beginning of the procedure body.
+
+
+@node Higher-order Arglists, Typing and Constants, Statement-lifting, Principles of Compilation
+@section Higher-order Arglists
+
+All procedures taking a list argument are converted into ordinary
+non-list taking procedures and they are called with the list-making
+calls inserted.  For example,
+
+@example
+@group
+(define foo
+  (lambda (x . y)
+    (cons x (reverse y)) ))
+@end group
+@end example
+
+is converted to
+
+@example
+@group
+(define foo
+  (lambda (x y)
+    (cons x (reverse y)) ))
+@end group
+@end example
+
+and any call to foo will make a list for a variable y.  For example,
+
+@example
+(foo 1 2 3)
+@end example
+
+is converted to
+
+@example
+(foo 1 (cons 2 (cons 3 '()))).
+@end example
+
+All higher-order procedure calls where an argument-term contains
+unbound variables will generate a new instance (provided it
+has not been created already) of this higher-order procedure,
+carrying the right amount of free variables inside to right
+places.
+
+For example, if there is a following definition:
+
+@example
+@group
+(define (member-if fn lst)
+   (if (fn (car lst))
+       lst
+       (member-if fn (cdr lst)) ))
+@end group
+@end example
+
+and a call
+
+@example
+(member-if (lambda (x) (eq? x y)) lst),
+@end example
+
+a new instance of member-if is created (if an analogous one
+has not been created before):
+
+@example
+@group
+(define (member-if_inst1 tmp fn lst)
+   (if (fn tmp (car lst))
+       lst
+       (member-if_inst1 tmp fn (cdr lst)) ))
+@end group
+@end example
+
+and the call is converted to
+
+@example
+(member-if_inst1 y foo lst)
+@end example
+
+and a top-level @t{define}
+
+@example
+(define (foo y x) (eq? x y))
+@end example
+
+In addition, if the higher-order procedure is to be exported,
+an additional instance is created, which uses apply to
+call all argument-procedures, assuming they are defined via interpreter.
+The exportable higher-order procedure will have a name @var{fun}_exporthof,
+where @var{fun} is the name of the original procedure.
+
+
+@node Typing and Constants,  , Higher-order Arglists, Principles of Compilation
+@section Typing and Constants
+
+All C<->Scheme conversions for immediate objects like numbers,
+booleans and characters are introduced.  Internal apply
+is used for undefined procedures.  Some optimizations are performed
+to decrease the amount of C<->Scheme object conversions.
+
+All vector, pair and string constants are replaced by new
+variables.  These variables are instantiated to the right
+values by init_@var{foo*}.
+
+Procedures foo which are to be exported (made accesible to the
+interpreter), and which have an arity different from one of the
+following five templates: x, (), (x), (x y), (x y z), are made
+accessible via an additional procedure foo_wrapper taking a single
+list argument.
+
+@subheading C Code Generation
+
+More or less straightforward.
+
+The type conversion between C objects and immediate Scheme objects of
+the type boolean, char and num is performed by macros.  The scheme
+object @t{'()} is represented by the macro object EOL.
+
+@subheading  Intermediate files
+
+Experiment yourself by defining:
+
+@example
+(define *build-intermediate-files* #t)
+@end example
+
+instead of the default:
+
+@example
+(define *build-intermediate-files* #f).
+@end example
+
+
+@node About Hobbit,  , Principles of Compilation, Top
+@chapter About Hobbit
+
+@menu
+* The Aims of Developing Hobbit::  
+* Manifest::                    
+* Author and Contributors::     
+* Future Improvements::         
+* Release History::             
+@end menu
+
+@node The Aims of Developing Hobbit, Manifest, About Hobbit, About Hobbit
+@section The Aims of Developing Hobbit
+
+@enumerate
+@item
+Producing maximally fast C code from simple scheme code.
+
+By @dfn{simple} we mean code which does not rely on procedures
+returning procedures (closures) and nontrivial forms of
+higher-order procedures.  All the latter are also compiled,
+but the optimizations specially target simple code fragments.
+Hobbit performs global optimization in order to locate such fragments.
+
+@item
+Producing C code which would preserve as much original scheme
+code structure as possible, to enable using the output C code
+by a human programmer (eg. for introducing special optimizations
+possible in C).  Also, this will hopefully help the C compiler
+to find better optimizations.
+@end enumerate
+
+
+@node Manifest, Author and Contributors, The Aims of Developing Hobbit, About Hobbit
+@section Manifest
+
+@multitable @columnfractions .2 .8
+@item @file{hobbit.scm}
+@tab the hobbit compiler.
+@item @file{scmhob.scm}
+@tab  the file defining some additional procedures recognized
+by hobbit as primitives.  Use it with the interpreter only.
+@item @file{scmhob.h}
+@tab the common headerfile for hobbit-compiled C files.
+@item @file{hobbit.texi}
+@tab documentation for hobbit.
+@end multitable
+
+
+@node Author and Contributors, Future Improvements, Manifest, About Hobbit
+@section Author and Contributors
+
+@quotation
+Tanel Tammet@*
+Department of Computing Science@*
+Chalmers University of Technology@*
+University of Go"teborg@*
+S-41296 Go"teborg Sweden
+@end quotation
+
+A. Jaffer (jaffer @@ alum.mit.edu), the author of SCM, has been of major
+help with a number of suggestions and hacks, especially concerning the
+interface between compiled code and the SCM interpreter.
+
+Several people have helped with suggestions and detailed bug reports,
+e.g. David J. Fiander (davidf@@mks.com), Gordon Oulsnam
+(STCS8004@@IRUCCVAX.UCC.IE), Pertti Kelloma"ki (pk@@cs.tut.fi),
+Dominique de Waleffe (ddw2@@sunbim.be) Terry Moore (tmm@@databook.com),
+Marshall Abrams (ab2r@@midway.uchicago.edu).  Georgy K. Bronnikov
+(goga@@bronnikov.msk.su), Bernard Urban (Bernard.URBAN@@meteo.fr),
+Charlie Xiaoli Huang, Tom Lord (lord@@cygnus.com),
+NMICHAEL@@us.oracle.com, Lee Iverson (leei@@ai.sri.com), Burt
+Leavenworth (EDLSOFT@@aol.com).
+
+
+@page
+@node Future Improvements, Release History, Author and Contributors, About Hobbit
+@section Future Improvements
+
+@enumerate
+@item
+Optimisations:
+
+@itemize
+@item
+the calls to internal apply: we'd like to avoid the excessive consing of
+always building the list of arguments.
+@item
+speeding up the creation of a vector for assignable closure-variables
+@item
+several peephole optimisations.
+@end itemize
+
+@item
+Improve Variable creation and naming to avoid C function name clashes.
+
+@item
+Report 4 macros.
+
+@item
+Better error-checking.
+
+@item
+Better liftability analysis.
+
+@item
+More tailrecursion recognition.
+
+@item
+Better numeric optimizations.
+
+@item
+Fast real-only arithmetics: $eqv, $=, $>, $+, $*, etc.
+@end enumerate
+
+
+@node Release History,  , Future Improvements, About Hobbit
+@section Release History
+
+@quotation
+[In February 2002, hobbit5x was integrated into the SCM distribution.
+Changes since then are recorded in @file{scm/ChangeLog}.]
+@end quotation
+
+@table @asis
+@item hobbit4d:
+@itemize @bullet
+@item
+the incorrect translation of char>?, char-ci>?, char>=?, char-ci>=?
+string>?, string-ci>?, string-ci>=?, string>=? reported by
+Burt Leavenworth (EDLSOFT@@aol.com) was fixed.
+@item
+the name clash bug for new variables new_varN occurring in
+non-liftable closures (reported by Lee Iverson (leei@@ai.sri.com))
+was fixed.
+@item
+the major COPYRIGHT change: differently from all the previous
+versions of Hobbit, hobbit4d is Free Software.
+@end itemize
+
+@item hobbit4c:
+@itemize @bullet
+@item
+a liftability-analysis bug for @t{for-each} and @t{map} reported
+by Lee Iverson (leei@@ai.sri.com) has been fixed.
+@item
+The output C code does not contain the unnecessary ;-s on
+separate lines any more.
+@end itemize
+
+@item hobbit4b:
+The following bugs have been fixed:
+@itemize @bullet
+@item
+Erroneous treatment of [ and ] inside symbols,
+reported by A. Jaffer (jaffer @@ alum.mit.edu).
+@item
+A bug in the liftability analysis,
+reported by A. Jaffer (jaffer @@ alum.mit.edu).
+@item
+A bug occurring in case arguments are evaluated right-to-left,
+which happens with Hobbit compiled by gcc on Linux.
+Reported and patched by George K. Bronnikov (goga@@bronnikov.msk.su)
+@item
+A closure-building bug sometimes leading to a serious loss of
+efficiency (liftability not recognized),
+reported by NMICHAEL@@us.oracle.com.
+@item
+A bug in the liftability analysis (non-liftable lambda-term
+inside a liftable lambda-term)
+reported by Lee Iverson (leei@@ai.sri.com)
+@end itemize
+
+@item hobbit4a:
+Several bugs found in version4x are fixed.
+
+@item hobbit4x (not public):
+@itemize @bullet
+@item
+A major overhaul: Hobbit is now able to compile full scheme,
+not just the fast liftable-clonable fragment.
+
+The optimizations done by the earlier versions are preserved.
+
+@item
+Numerous bugs found in earlier versions have been fixed.
+@end itemize
+
+@item hobbit3d:
+bugs found in the version 3c are fixed.
+
+@item hobbit3c:
+@itemize @bullet
+@item
+the form
+
+@example
+(define foo (let ((x1 <t1>) @dots{} (xn <tn>)) (lambda @dots{})))
+@end example
+
+is now supported for all terms <ti> except procedures defined
+in the compiled files.
+@item
+macros are partially supported by doing a preprocessing pass using the
+procedures pprint-filter-file and defmacro:expand* defined
+in slib.
+@item
+the file @file{scmhob.scm} defining hobbit-recognized nonstandard
+procedures is created.
+@item
+the documentation is improved (thanks go to Aubrey for suggestions).
+@end itemize
+
+@item hobbit3b:
+@itemize @bullet
+@item
+Aubrey fixed some problems with the version 3.
+@item
+It is now OK to define procedures "by name" on top level.
+@item
+It is now OK to apply "apply", etc to procedures defined
+in the compiled file.  Compiled procedures may now be passed
+to procedures not defined but still called in the compiled files.
+@end itemize
+
+@item hobbit3:
+@itemize @bullet
+@item
+Generic arithmetic supported by SCM (exact and inexact reals,
+bignums) is made available.
+@item
+The #. special syntactic form of SCM is made available.
+@item
+Procedures with chars are compiled open-coded, making them faster.
+@item
+The bug concerning strings containing an embedded \nl char
+is corrected (thanks to Terry Moore, (tmm@@databook.com)).
+@item
+The special declaration compile-stable-vectors for optimizing
+vector access is introduced.
+@item
+Source code may contain top-level computations, top-level
+loads are ignored.
+@item
+The bug causing "or" to (sometimes) lose tailrecursiveness is corrected.
+@item
+Hobbit now allows the following very special form:
+
+@example
+(define foo (let ((bar bar)) (lambda @dots{})))
+@end example
+
+Notice @code{(bar bar)}.  See the section 5 above.  It will produce wrong
+code if bar is redefined.
+
+There were several versions of the 2-series, like 2.x, which were
+not made public.  The changes introduced are present in the version 3.
+@end itemize
+
+@item hobbit2:
+@itemize @bullet
+@item
+The following bitwise procedures in the scheme library file
+@file{logical.scm} are compiled directly to C
+(Scheme library funs in the upper row, C ops below):
+
+@example
+@group
+logand logior logxor lognot logsleft logsright
+   &      |     ^      ~       <<        >>
+@end group
+@end example
+
+Notice that the procedures @t{logsleft}, @t{logsright} are @b{NOT} in
+the the library file @file{logical.scm}: the universal procedure @t{ash}
+is instead.  Procedures @t{ash}, @t{logcount}, @t{integer-length},
+@t{integer-expt}, @t{bit-extract} in @file{logical.scm} are not
+recognized by hobbit.
+@end itemize
+
+@item hobbit1a3 (not public):
+@itemize @bullet
+@item
+the @t{letrec}-sorting bug often resulting in not recognizing procedures
+defined in @t{letrec} (or local @t{define}s) has been corrected.
+@item
+the primitives @t{string} and @t{vector} are now compiled correctly.
+@end itemize
+
+@item hobbit1a2 (not public):
+@itemize @bullet
+@item
+any fixed arity procedure (including primitives) may be passed to any
+higher-order procedure by name.  Variable arity procedures (eg
+primitives @t{list}, @t{+}, @t{display} and defined funs like
+@code{(define (foo x . y) x)}) must not be passed to new defined
+higher-order funs.
+@item
+some optimizations have been introduced for calls to @t{map}
+and @t{for-each}.
+@item
+(map list x y) bug has been corrected.
+@item
+Corrected self-compilation name clash between call_cc and call-cc.
+@end itemize
+
+@item hobbit1a1 (not public):
+@itemize @bullet
+@item
+named let is supported.
+@item
+the inlining bug is fixed: all procedures declared to be
+inlined are fully inlined, except when the flag
+*full-inlining-flag* is defined as #f.
+@item
+the @t{letrec} (or in-procedure define) bug where local procedure
+names were not recognized, is fixed.
+@item
+documentation says explicitly that definitions like
+
+@example
+(define foo (let ((x 0)) (lambda (y) @dots{})))
+@end example
+
+are assumed to be closure-returning procedures and are prohibited.
+@item
+documentation allows more liberty with passing procedures to
+higher-order funs by dropping the general requirement that only unnamed
+lambda-terms may be passed.  Still, primitives and list-taking
+procedures may not be passed by name.
+@item
+documentation prohibits passing lambda-terms with free variables to
+recursive calls of higher-order procedures in the definition of a
+higher-order procedure.
+@end itemize
+
+@item hobbit1:
+the first release
+@end table
+
+
+@contents
+@bye
diff --git a/inc2scm b/inc2scm
index 58a9540..5037e2c 100755
--- a/inc2scm
+++ b/inc2scm
@@ -17,26 +17,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -44,8 +44,7 @@
 ;;; Author: Aubrey Jaffer.
 
 (define (go-script)
-  (cond ((not *script*))
-	((< 1 (- (length *argv*) *optind*))
+  (cond ((< 1 (- (length *argv*) *optind*))
 	 (apply inc2scm (list-tail *argv* *optind*)))
 	(else
 	 (display "\
@@ -151,8 +150,9 @@ Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ...
 		  filename
 		  "\\n\");")
 	 (for-each
-	  (lambda (name) (fprintf cport "  pSl(\"%s\", %s);\\n"
-				  (schemeify-name pre name) name))
+	  (lambda (name)
+	    (fprintf cport "#ifdef %s\\n  pSl(\"%s\", %s);\\n#endif\\n"
+		     name (schemeify-name pre name) name))
 	  (call-with-input-file filename extract-defineds)))
        filenames)
       (fprintf cport "}\\n")))
diff --git a/ioext.c b/ioext.c
index 1d7f68b..62ec8b2 100644
--- a/ioext.c
+++ b/ioext.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -70,8 +70,11 @@ SCM	stat2scm P((struct stat *stat_temp));
 #ifdef __FreeBSD__
 # include <unistd.h>
 #endif
+#ifdef __OpenBSD__
+# include <unistd.h>
+#endif
 /* added by Denys Duchier */
-#ifdef __svr4__
+#ifdef __SVR4
 # include <sys/types.h>
 # include <unistd.h>
 #endif
@@ -81,6 +84,12 @@ SCM	stat2scm P((struct stat *stat_temp));
 #ifdef GO32
 # include <unistd.h>
 #endif
+#ifdef __osf__
+# include <unistd.h>
+#endif
+#ifdef __MACH__
+# include <unistd.h>
+#endif
 
 #ifndef STDC_HEADERS
 	int chdir P((const char *path));
@@ -198,6 +207,20 @@ SCM file_set_position(port, pos)
 {
 	SCM ans;
 	ASSERT(NIMP(port) && OPFPORTP(port), port, ARG1, s_file_set_pos);
+#ifndef RECKLESS
+	if (TRACKED & SCM_PORTFLAGS(port)) {
+	  if (INUM0==pos) {
+	    int i = SCM_PORTNUM(port);
+	    scm_port_table[i].line = 1L;
+	    scm_port_table[i].col = 1;
+	  }
+	  else {
+	    if (2 <= verbose)
+	      scm_warn("Setting file position for tracked port: ", "", port);
+	    SCM_PORTFLAGS(port) &= (~TRACKED);
+	  }
+	}
+#endif
 	CLRDY(port);		/* Clear ungetted char */
 	SYSCALL(ans = (fseek(STREAM(port), INUM(pos), 0)) ? BOOL_F : BOOL_T;);
 #ifdef HAVE_PIPE
@@ -217,8 +240,9 @@ SCM reopen_file(filename, modes, port)
   char cmodes[4];
   long flags;
   ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_reopen_file);
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_reopen_file);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_reopen_file);
   flags =  mode_bits(CHARS(modes), cmodes);
+  ASSERT(flags, modes, ARG2, s_reopen_file);
   DEFER_INTS;
   ASSERT(NIMP(port) && FPORTP(port) && OPENP(port), port, ARG3, s_reopen_file);
   SCM_OPENCALL(f = freopen(CHARS(filename), cmodes, STREAM(port)));
@@ -227,14 +251,13 @@ SCM reopen_file(filename, modes, port)
     return BOOL_F;
   }
   else {
-    SETSTREAM(port, f);
     SCM_PORTFLAGS(port) = flags;
-    CAR(port) = scm_port_entry(tc16_fport, flags);
+    SCM_SETFLAGS(port, flags);
     if (BUF0 & flags)
       i_setbuf0(port);
+    SCM_PORTDATA(port) = filename;
   }
   ALLOW_INTS;
-  SCM_PORTDATA(port) = filename;
   return port;
 }
 
@@ -250,19 +273,25 @@ SCM l_dup(oldpt, modes)
   FILE *f;
   SCM newpt;
   ASSERT(NIMP(oldpt) && OPFPORTP(oldpt), oldpt, ARG1, s_dup);
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_dup);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_dup);
   flags = mode_bits(CHARS(modes), cmodes);
+  ASSERT(flags, modes, ARG2, s_dup);
   NEWCELL(newpt);
   DEFER_INTS;
   SCM_OPENCALL(tfd = dup(fileno(STREAM(oldpt))));
   if (-1==tfd) {ALLOW_INTS;return BOOL_F;};
   SYSCALL(f = fdopen(tfd, cmodes););
   if (!f) {
+    int lerrno = errno;
     close(tfd);
+    errno = lerrno;
+#  ifdef EINVAL
+    if (lerrno==EINVAL) wta(modes, (char *)ARG2, s_dup);
+#  endif
     wta(MAKINUM(tfd), (char *)NALLOC, s_port_type);
   }
-  SETSTREAM(newpt, f);
-  CAR(newpt) = scm_port_entry(tc16_fport, flags);
+  newpt = scm_port_entry(f, tc16_fport, flags);
+  SCM_PORTDATA(newpt) = SCM_PORTDATA(oldpt);
   if (BUF0 & flags)
     i_setbuf0(newpt);
   ALLOW_INTS;
@@ -690,6 +719,49 @@ static iproc subr2s[] = {
 #endif
 	{0, 0}};
 
+#include <fcntl.h>		/* for O_RDONLY, O_RDWR, O_EXCL */
+#ifdef O_EXCL
+SCM scm_try_create_file(fname, modes, perms)
+     SCM fname, modes, perms;
+{
+  SCM port;
+  FILE *f;
+  char cmodes[4];
+  long flags;
+  int fd, fdflags = O_CREAT | O_EXCL;
+# ifdef S_IROTH
+  mode_t cperms = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
+# else
+  int cperms = 0666;
+# endif
+  ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_try_create_file);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_try_create_file);
+  if (NNULLP(perms)) {
+    perms = CAR(perms);
+    ASSERT(INUMP(perms), perms, ARG3, s_try_create_file);
+# ifdef S_IROTH
+    cperms = (mode_t)INUM(perms);
+# else
+    cperms = INUM(perms);
+# endif
+  }
+  flags = mode_bits(CHARS(modes), cmodes);
+  ASSERT(flags, modes, ARG2, s_try_create_file);
+  fdflags |= (RDNG & flags) ? O_RDWR : O_WRONLY;
+  DEFER_INTS;
+  SCM_OPENCALL(fd = open(CHARS(fname), fdflags, cperms));
+  if (fd >= 0 && (f = fdopen(fd, cmodes))) {
+    port = scm_port_entry(f, tc16_fport, flags);
+    if (BUF0 & flags) i_setbuf0(port);
+    SCM_PORTDATA(port) = fname;
+  }
+  else
+    port = BOOL_F;
+  ALLOW_INTS;
+  return port;
+}
+#endif
+
 static iproc subr2os[] = {
 	{s_file_set_pos, file_set_position},
 	{s_read_line1, read_line1},
@@ -702,6 +774,9 @@ void init_ioext()
 	init_iprocs(subr1s, tc7_subr_1);
 	init_iprocs(subr2os, tc7_subr_2o);
 	init_iprocs(subr2s, tc7_subr_2);
+#ifdef O_EXCL
+	make_subr(s_try_create_file, tc7_lsubr_2, scm_try_create_file);
+#endif
 	make_subr(s_reopen_file, tc7_subr_3, reopen_file);
 #ifndef THINK_C
 # ifndef MCH_AMIGA
@@ -733,6 +808,7 @@ void init_ioext()
 	add_feature("i/o-extensions");
 	add_feature("line-i/o");
 	scm_ldstr("\n\
+(define (file-exists? path) (access path \"r\"))\n\
 (define (directory-for-each proc dirname . args)\n\
   (define dir (opendir (if (symbol? dirname)\n\
 			   (symbol->string dirname)\n\
diff --git a/keysymdef.scm b/keysymdef.scm
new file mode 100644
index 0000000..d35fcc7
--- /dev/null
+++ b/keysymdef.scm
@@ -0,0 +1,674 @@
+;;inc2scm extracted #define values from /usr/include/X11/keysym.h
+;;inc2scm extracted #define values from /usr/include/X11/keysymdef.h
+(define XK:VoidSymbol 16777215)
+(define XK:BackSpace 65288)
+(define XK:Tab 65289)
+(define XK:Linefeed 65290)
+(define XK:Clear 65291)
+(define XK:Return 65293)
+(define XK:Pause 65299)
+(define XK:Scroll-Lock 65300)
+(define XK:Sys-Req 65301)
+(define XK:Escape 65307)
+(define XK:Delete 65535)
+(define XK:Multi-key 65312)
+(define XK:Codeinput 65335)
+(define XK:SingleCandidate 65340)
+(define XK:MultipleCandidate 65341)
+(define XK:PreviousCandidate 65342)
+(define XK:Kanji 65313)
+(define XK:Muhenkan 65314)
+(define XK:Henkan-Mode 65315)
+(define XK:Henkan 65315)
+(define XK:Romaji 65316)
+(define XK:Hiragana 65317)
+(define XK:Katakana 65318)
+(define XK:Hiragana-Katakana 65319)
+(define XK:Zenkaku 65320)
+(define XK:Hankaku 65321)
+(define XK:Zenkaku-Hankaku 65322)
+(define XK:Touroku 65323)
+(define XK:Massyo 65324)
+(define XK:Kana-Lock 65325)
+(define XK:Kana-Shift 65326)
+(define XK:Eisu-Shift 65327)
+(define XK:Eisu-toggle 65328)
+(define XK:Kanji-Bangou 65335)
+(define XK:Zen-Koho 65341)
+(define XK:Mae-Koho 65342)
+(define XK:Home 65360)
+(define XK:Left 65361)
+(define XK:Up 65362)
+(define XK:Right 65363)
+(define XK:Down 65364)
+(define XK:Prior 65365)
+(define XK:Page-Up 65365)
+(define XK:Next 65366)
+(define XK:Page-Down 65366)
+(define XK:End 65367)
+(define XK:Begin 65368)
+(define XK:Select 65376)
+(define XK:Print 65377)
+(define XK:Execute 65378)
+(define XK:Insert 65379)
+(define XK:Undo 65381)
+(define XK:Redo 65382)
+(define XK:Menu 65383)
+(define XK:Find 65384)
+(define XK:Cancel 65385)
+(define XK:Help 65386)
+(define XK:Break 65387)
+(define XK:Mode-switch 65406)
+(define XK:script-switch 65406)
+(define XK:Num-Lock 65407)
+(define XK:KP-Space 65408)
+(define XK:KP-Tab 65417)
+(define XK:KP-Enter 65421)
+(define XK:KP-F1 65425)
+(define XK:KP-F2 65426)
+(define XK:KP-F3 65427)
+(define XK:KP-F4 65428)
+(define XK:KP-Home 65429)
+(define XK:KP-Left 65430)
+(define XK:KP-Up 65431)
+(define XK:KP-Right 65432)
+(define XK:KP-Down 65433)
+(define XK:KP-Prior 65434)
+(define XK:KP-Page-Up 65434)
+(define XK:KP-Next 65435)
+(define XK:KP-Page-Down 65435)
+(define XK:KP-End 65436)
+(define XK:KP-Begin 65437)
+(define XK:KP-Insert 65438)
+(define XK:KP-Delete 65439)
+(define XK:KP-Equal 65469)
+(define XK:KP-Multiply 65450)
+(define XK:KP-Add 65451)
+(define XK:KP-Separator 65452)
+(define XK:KP-Subtract 65453)
+(define XK:KP-Decimal 65454)
+(define XK:KP-Divide 65455)
+(define XK:KP-0 65456)
+(define XK:KP-1 65457)
+(define XK:KP-2 65458)
+(define XK:KP-3 65459)
+(define XK:KP-4 65460)
+(define XK:KP-5 65461)
+(define XK:KP-6 65462)
+(define XK:KP-7 65463)
+(define XK:KP-8 65464)
+(define XK:KP-9 65465)
+(define XK:F1 65470)
+(define XK:F2 65471)
+(define XK:F3 65472)
+(define XK:F4 65473)
+(define XK:F5 65474)
+(define XK:F6 65475)
+(define XK:F7 65476)
+(define XK:F8 65477)
+(define XK:F9 65478)
+(define XK:F10 65479)
+(define XK:F11 65480)
+(define XK:L1 65480)
+(define XK:F12 65481)
+(define XK:L2 65481)
+(define XK:F13 65482)
+(define XK:L3 65482)
+(define XK:F14 65483)
+(define XK:L4 65483)
+(define XK:F15 65484)
+(define XK:L5 65484)
+(define XK:F16 65485)
+(define XK:L6 65485)
+(define XK:F17 65486)
+(define XK:L7 65486)
+(define XK:F18 65487)
+(define XK:L8 65487)
+(define XK:F19 65488)
+(define XK:L9 65488)
+(define XK:F20 65489)
+(define XK:L10 65489)
+(define XK:F21 65490)
+(define XK:R1 65490)
+(define XK:F22 65491)
+(define XK:R2 65491)
+(define XK:F23 65492)
+(define XK:R3 65492)
+(define XK:F24 65493)
+(define XK:R4 65493)
+(define XK:F25 65494)
+(define XK:R5 65494)
+(define XK:F26 65495)
+(define XK:R6 65495)
+(define XK:F27 65496)
+(define XK:R7 65496)
+(define XK:F28 65497)
+(define XK:R8 65497)
+(define XK:F29 65498)
+(define XK:R9 65498)
+(define XK:F30 65499)
+(define XK:R10 65499)
+(define XK:F31 65500)
+(define XK:R11 65500)
+(define XK:F32 65501)
+(define XK:R12 65501)
+(define XK:F33 65502)
+(define XK:R13 65502)
+(define XK:F34 65503)
+(define XK:R14 65503)
+(define XK:F35 65504)
+(define XK:R15 65504)
+(define XK:Shift-L 65505)
+(define XK:Shift-R 65506)
+(define XK:Control-L 65507)
+(define XK:Control-R 65508)
+(define XK:Caps-Lock 65509)
+(define XK:Shift-Lock 65510)
+(define XK:Meta-L 65511)
+(define XK:Meta-R 65512)
+(define XK:Alt-L 65513)
+(define XK:Alt-R 65514)
+(define XK:Super-L 65515)
+(define XK:Super-R 65516)
+(define XK:Hyper-L 65517)
+(define XK:Hyper-R 65518)
+(define XK:ISO-Lock 65025)
+(define XK:ISO-Level2-Latch 65026)
+(define XK:ISO-Level3-Shift 65027)
+(define XK:ISO-Level3-Latch 65028)
+(define XK:ISO-Level3-Lock 65029)
+(define XK:ISO-Group-Shift 65406)
+(define XK:ISO-Group-Latch 65030)
+(define XK:ISO-Group-Lock 65031)
+(define XK:ISO-Next-Group 65032)
+(define XK:ISO-Next-Group-Lock 65033)
+(define XK:ISO-Prev-Group 65034)
+(define XK:ISO-Prev-Group-Lock 65035)
+(define XK:ISO-First-Group 65036)
+(define XK:ISO-First-Group-Lock 65037)
+(define XK:ISO-Last-Group 65038)
+(define XK:ISO-Last-Group-Lock 65039)
+(define XK:ISO-Left-Tab 65056)
+(define XK:ISO-Move-Line-Up 65057)
+(define XK:ISO-Move-Line-Down 65058)
+(define XK:ISO-Partial-Line-Up 65059)
+(define XK:ISO-Partial-Line-Down 65060)
+(define XK:ISO-Partial-Space-Left 65061)
+(define XK:ISO-Partial-Space-Right 65062)
+(define XK:ISO-Set-Margin-Left 65063)
+(define XK:ISO-Set-Margin-Right 65064)
+(define XK:ISO-Release-Margin-Left 65065)
+(define XK:ISO-Release-Margin-Right 65066)
+(define XK:ISO-Release-Both-Margins 65067)
+(define XK:ISO-Fast-Cursor-Left 65068)
+(define XK:ISO-Fast-Cursor-Right 65069)
+(define XK:ISO-Fast-Cursor-Up 65070)
+(define XK:ISO-Fast-Cursor-Down 65071)
+(define XK:ISO-Continuous-Underline 65072)
+(define XK:ISO-Discontinuous-Underline 65073)
+(define XK:ISO-Emphasize 65074)
+(define XK:ISO-Center-Object 65075)
+(define XK:ISO-Enter 65076)
+(define XK:dead-grave 65104)
+(define XK:dead-acute 65105)
+(define XK:dead-circumflex 65106)
+(define XK:dead-tilde 65107)
+(define XK:dead-macron 65108)
+(define XK:dead-breve 65109)
+(define XK:dead-abovedot 65110)
+(define XK:dead-diaeresis 65111)
+(define XK:dead-abovering 65112)
+(define XK:dead-doubleacute 65113)
+(define XK:dead-caron 65114)
+(define XK:dead-cedilla 65115)
+(define XK:dead-ogonek 65116)
+(define XK:dead-iota 65117)
+(define XK:dead-voiced-sound 65118)
+(define XK:dead-semivoiced-sound 65119)
+(define XK:dead-belowdot 65120)
+(define XK:First-Virtual-Screen 65232)
+(define XK:Prev-Virtual-Screen 65233)
+(define XK:Next-Virtual-Screen 65234)
+(define XK:Last-Virtual-Screen 65236)
+(define XK:Terminate-Server 65237)
+(define XK:AccessX-Enable 65136)
+(define XK:AccessX-Feedback-Enable 65137)
+(define XK:RepeatKeys-Enable 65138)
+(define XK:SlowKeys-Enable 65139)
+(define XK:BounceKeys-Enable 65140)
+(define XK:StickyKeys-Enable 65141)
+(define XK:MouseKeys-Enable 65142)
+(define XK:MouseKeys-Accel-Enable 65143)
+(define XK:Overlay1-Enable 65144)
+(define XK:Overlay2-Enable 65145)
+(define XK:AudibleBell-Enable 65146)
+(define XK:Pointer-Left 65248)
+(define XK:Pointer-Right 65249)
+(define XK:Pointer-Up 65250)
+(define XK:Pointer-Down 65251)
+(define XK:Pointer-UpLeft 65252)
+(define XK:Pointer-UpRight 65253)
+(define XK:Pointer-DownLeft 65254)
+(define XK:Pointer-DownRight 65255)
+(define XK:Pointer-Button-Dflt 65256)
+(define XK:Pointer-Button1 65257)
+(define XK:Pointer-Button2 65258)
+(define XK:Pointer-Button3 65259)
+(define XK:Pointer-Button4 65260)
+(define XK:Pointer-Button5 65261)
+(define XK:Pointer-DblClick-Dflt 65262)
+(define XK:Pointer-DblClick1 65263)
+(define XK:Pointer-DblClick2 65264)
+(define XK:Pointer-DblClick3 65265)
+(define XK:Pointer-DblClick4 65266)
+(define XK:Pointer-DblClick5 65267)
+(define XK:Pointer-Drag-Dflt 65268)
+(define XK:Pointer-Drag1 65269)
+(define XK:Pointer-Drag2 65270)
+(define XK:Pointer-Drag3 65271)
+(define XK:Pointer-Drag4 65272)
+(define XK:Pointer-Drag5 65277)
+(define XK:Pointer-EnableKeys 65273)
+(define XK:Pointer-Accelerate 65274)
+(define XK:Pointer-DfltBtnNext 65275)
+(define XK:Pointer-DfltBtnPrev 65276)
+(define XK:space 32)
+(define XK:exclam 33)
+(define XK:quotedbl 34)
+(define XK:numbersign 35)
+(define XK:dollar 36)
+(define XK:percent 37)
+(define XK:ampersand 38)
+(define XK:apostrophe 39)
+(define XK:quoteright 39)
+(define XK:parenleft 40)
+(define XK:parenright 41)
+(define XK:asterisk 42)
+(define XK:plus 43)
+(define XK:comma 44)
+(define XK:minus 45)
+(define XK:period 46)
+(define XK:slash 47)
+(define XK:0 48)
+(define XK:1 49)
+(define XK:2 50)
+(define XK:3 51)
+(define XK:4 52)
+(define XK:5 53)
+(define XK:6 54)
+(define XK:7 55)
+(define XK:8 56)
+(define XK:9 57)
+(define XK:colon 58)
+(define XK:semicolon 59)
+(define XK:less 60)
+(define XK:equal 61)
+(define XK:greater 62)
+(define XK:question 63)
+(define XK:at 64)
+(define XK:A 65)
+(define XK:B 66)
+(define XK:C 67)
+(define XK:D 68)
+(define XK:E 69)
+(define XK:F 70)
+(define XK:G 71)
+(define XK:H 72)
+(define XK:I 73)
+(define XK:J 74)
+(define XK:K 75)
+(define XK:L 76)
+(define XK:M 77)
+(define XK:N 78)
+(define XK:O 79)
+(define XK:P 80)
+(define XK:Q 81)
+(define XK:R 82)
+(define XK:S 83)
+(define XK:T 84)
+(define XK:U 85)
+(define XK:V 86)
+(define XK:W 87)
+(define XK:X 88)
+(define XK:Y 89)
+(define XK:Z 90)
+(define XK:bracketleft 91)
+(define XK:backslash 92)
+(define XK:bracketright 93)
+(define XK:asciicircum 94)
+(define XK:underscore 95)
+(define XK:grave 96)
+(define XK:quoteleft 96)
+(define XK:a 97)
+(define XK:b 98)
+(define XK:c 99)
+(define XK:d 100)
+(define XK:e 101)
+(define XK:f 102)
+(define XK:g 103)
+(define XK:h 104)
+(define XK:i 105)
+(define XK:j 106)
+(define XK:k 107)
+(define XK:l 108)
+(define XK:m 109)
+(define XK:n 110)
+(define XK:o 111)
+(define XK:p 112)
+(define XK:q 113)
+(define XK:r 114)
+(define XK:s 115)
+(define XK:t 116)
+(define XK:u 117)
+(define XK:v 118)
+(define XK:w 119)
+(define XK:x 120)
+(define XK:y 121)
+(define XK:z 122)
+(define XK:braceleft 123)
+(define XK:bar 124)
+(define XK:braceright 125)
+(define XK:asciitilde 126)
+(define XK:nobreakspace 160)
+(define XK:exclamdown 161)
+(define XK:cent 162)
+(define XK:sterling 163)
+(define XK:currency 164)
+(define XK:yen 165)
+(define XK:brokenbar 166)
+(define XK:section 167)
+(define XK:diaeresis 168)
+(define XK:copyright 169)
+(define XK:ordfeminine 170)
+(define XK:guillemotleft 171)
+(define XK:notsign 172)
+(define XK:hyphen 173)
+(define XK:registered 174)
+(define XK:macron 175)
+(define XK:degree 176)
+(define XK:plusminus 177)
+(define XK:twosuperior 178)
+(define XK:threesuperior 179)
+(define XK:acute 180)
+(define XK:mu 181)
+(define XK:paragraph 182)
+(define XK:periodcentered 183)
+(define XK:cedilla 184)
+(define XK:onesuperior 185)
+(define XK:masculine 186)
+(define XK:guillemotright 187)
+(define XK:onequarter 188)
+(define XK:onehalf 189)
+(define XK:threequarters 190)
+(define XK:questiondown 191)
+(define XK:Agrave 192)
+(define XK:Aacute 193)
+(define XK:Acircumflex 194)
+(define XK:Atilde 195)
+(define XK:Adiaeresis 196)
+(define XK:Aring 197)
+(define XK:AE 198)
+(define XK:Ccedilla 199)
+(define XK:Egrave 200)
+(define XK:Eacute 201)
+(define XK:Ecircumflex 202)
+(define XK:Ediaeresis 203)
+(define XK:Igrave 204)
+(define XK:Iacute 205)
+(define XK:Icircumflex 206)
+(define XK:Idiaeresis 207)
+(define XK:ETH 208)
+(define XK:Eth 208)
+(define XK:Ntilde 209)
+(define XK:Ograve 210)
+(define XK:Oacute 211)
+(define XK:Ocircumflex 212)
+(define XK:Otilde 213)
+(define XK:Odiaeresis 214)
+(define XK:multiply 215)
+(define XK:Ooblique 216)
+(define XK:Ugrave 217)
+(define XK:Uacute 218)
+(define XK:Ucircumflex 219)
+(define XK:Udiaeresis 220)
+(define XK:Yacute 221)
+(define XK:THORN 222)
+(define XK:Thorn 222)
+(define XK:ssharp 223)
+(define XK:agrave 224)
+(define XK:aacute 225)
+(define XK:acircumflex 226)
+(define XK:atilde 227)
+(define XK:adiaeresis 228)
+(define XK:aring 229)
+(define XK:ae 230)
+(define XK:ccedilla 231)
+(define XK:egrave 232)
+(define XK:eacute 233)
+(define XK:ecircumflex 234)
+(define XK:ediaeresis 235)
+(define XK:igrave 236)
+(define XK:iacute 237)
+(define XK:icircumflex 238)
+(define XK:idiaeresis 239)
+(define XK:eth 240)
+(define XK:ntilde 241)
+(define XK:ograve 242)
+(define XK:oacute 243)
+(define XK:ocircumflex 244)
+(define XK:otilde 245)
+(define XK:odiaeresis 246)
+(define XK:division 247)
+(define XK:oslash 248)
+(define XK:ugrave 249)
+(define XK:uacute 250)
+(define XK:ucircumflex 251)
+(define XK:udiaeresis 252)
+(define XK:yacute 253)
+(define XK:thorn 254)
+(define XK:ydiaeresis 255)
+(define XK:Aogonek 417)
+(define XK:breve 418)
+(define XK:Lstroke 419)
+(define XK:Lcaron 421)
+(define XK:Sacute 422)
+(define XK:Scaron 425)
+(define XK:Scedilla 426)
+(define XK:Tcaron 427)
+(define XK:Zacute 428)
+(define XK:Zcaron 430)
+(define XK:Zabovedot 431)
+(define XK:aogonek 433)
+(define XK:ogonek 434)
+(define XK:lstroke 435)
+(define XK:lcaron 437)
+(define XK:sacute 438)
+(define XK:caron 439)
+(define XK:scaron 441)
+(define XK:scedilla 442)
+(define XK:tcaron 443)
+(define XK:zacute 444)
+(define XK:doubleacute 445)
+(define XK:zcaron 446)
+(define XK:zabovedot 447)
+(define XK:Racute 448)
+(define XK:Abreve 451)
+(define XK:Lacute 453)
+(define XK:Cacute 454)
+(define XK:Ccaron 456)
+(define XK:Eogonek 458)
+(define XK:Ecaron 460)
+(define XK:Dcaron 463)
+(define XK:Dstroke 464)
+(define XK:Nacute 465)
+(define XK:Ncaron 466)
+(define XK:Odoubleacute 469)
+(define XK:Rcaron 472)
+(define XK:Uring 473)
+(define XK:Udoubleacute 475)
+(define XK:Tcedilla 478)
+(define XK:racute 480)
+(define XK:abreve 483)
+(define XK:lacute 485)
+(define XK:cacute 486)
+(define XK:ccaron 488)
+(define XK:eogonek 490)
+(define XK:ecaron 492)
+(define XK:dcaron 495)
+(define XK:dstroke 496)
+(define XK:nacute 497)
+(define XK:ncaron 498)
+(define XK:odoubleacute 501)
+(define XK:udoubleacute 507)
+(define XK:rcaron 504)
+(define XK:uring 505)
+(define XK:tcedilla 510)
+(define XK:abovedot 511)
+(define XK:Hstroke 673)
+(define XK:Hcircumflex 678)
+(define XK:Iabovedot 681)
+(define XK:Gbreve 683)
+(define XK:Jcircumflex 684)
+(define XK:hstroke 689)
+(define XK:hcircumflex 694)
+(define XK:idotless 697)
+(define XK:gbreve 699)
+(define XK:jcircumflex 700)
+(define XK:Cabovedot 709)
+(define XK:Ccircumflex 710)
+(define XK:Gabovedot 725)
+(define XK:Gcircumflex 728)
+(define XK:Ubreve 733)
+(define XK:Scircumflex 734)
+(define XK:cabovedot 741)
+(define XK:ccircumflex 742)
+(define XK:gabovedot 757)
+(define XK:gcircumflex 760)
+(define XK:ubreve 765)
+(define XK:scircumflex 766)
+(define XK:kra 930)
+(define XK:kappa 930)
+(define XK:Rcedilla 931)
+(define XK:Itilde 933)
+(define XK:Lcedilla 934)
+(define XK:Emacron 938)
+(define XK:Gcedilla 939)
+(define XK:Tslash 940)
+(define XK:rcedilla 947)
+(define XK:itilde 949)
+(define XK:lcedilla 950)
+(define XK:emacron 954)
+(define XK:gcedilla 955)
+(define XK:tslash 956)
+(define XK:ENG 957)
+(define XK:eng 959)
+(define XK:Amacron 960)
+(define XK:Iogonek 967)
+(define XK:Eabovedot 972)
+(define XK:Imacron 975)
+(define XK:Ncedilla 977)
+(define XK:Omacron 978)
+(define XK:Kcedilla 979)
+(define XK:Uogonek 985)
+(define XK:Utilde 989)
+(define XK:Umacron 990)
+(define XK:amacron 992)
+(define XK:iogonek 999)
+(define XK:eabovedot 1004)
+(define XK:imacron 1007)
+(define XK:ncedilla 1009)
+(define XK:omacron 1010)
+(define XK:kcedilla 1011)
+(define XK:uogonek 1017)
+(define XK:utilde 1021)
+(define XK:umacron 1022)
+(define XK:OE 5052)
+(define XK:oe 5053)
+(define XK:Ydiaeresis 5054)
+(define XK:Greek-ALPHAaccent 1953)
+(define XK:Greek-EPSILONaccent 1954)
+(define XK:Greek-ETAaccent 1955)
+(define XK:Greek-IOTAaccent 1956)
+(define XK:Greek-IOTAdiaeresis 1957)
+(define XK:Greek-OMICRONaccent 1959)
+(define XK:Greek-UPSILONaccent 1960)
+(define XK:Greek-UPSILONdieresis 1961)
+(define XK:Greek-OMEGAaccent 1963)
+(define XK:Greek-accentdieresis 1966)
+(define XK:Greek-horizbar 1967)
+(define XK:Greek-alphaaccent 1969)
+(define XK:Greek-epsilonaccent 1970)
+(define XK:Greek-etaaccent 1971)
+(define XK:Greek-iotaaccent 1972)
+(define XK:Greek-iotadieresis 1973)
+(define XK:Greek-iotaaccentdieresis 1974)
+(define XK:Greek-omicronaccent 1975)
+(define XK:Greek-upsilonaccent 1976)
+(define XK:Greek-upsilondieresis 1977)
+(define XK:Greek-upsilonaccentdieresis 1978)
+(define XK:Greek-omegaaccent 1979)
+(define XK:Greek-ALPHA 1985)
+(define XK:Greek-BETA 1986)
+(define XK:Greek-GAMMA 1987)
+(define XK:Greek-DELTA 1988)
+(define XK:Greek-EPSILON 1989)
+(define XK:Greek-ZETA 1990)
+(define XK:Greek-ETA 1991)
+(define XK:Greek-THETA 1992)
+(define XK:Greek-IOTA 1993)
+(define XK:Greek-KAPPA 1994)
+(define XK:Greek-LAMDA 1995)
+(define XK:Greek-LAMBDA 1995)
+(define XK:Greek-MU 1996)
+(define XK:Greek-NU 1997)
+(define XK:Greek-XI 1998)
+(define XK:Greek-OMICRON 1999)
+(define XK:Greek-PI 2000)
+(define XK:Greek-RHO 2001)
+(define XK:Greek-SIGMA 2002)
+(define XK:Greek-TAU 2004)
+(define XK:Greek-UPSILON 2005)
+(define XK:Greek-PHI 2006)
+(define XK:Greek-CHI 2007)
+(define XK:Greek-PSI 2008)
+(define XK:Greek-OMEGA 2009)
+(define XK:Greek-alpha 2017)
+(define XK:Greek-beta 2018)
+(define XK:Greek-gamma 2019)
+(define XK:Greek-delta 2020)
+(define XK:Greek-epsilon 2021)
+(define XK:Greek-zeta 2022)
+(define XK:Greek-eta 2023)
+(define XK:Greek-theta 2024)
+(define XK:Greek-iota 2025)
+(define XK:Greek-kappa 2026)
+(define XK:Greek-lamda 2027)
+(define XK:Greek-lambda 2027)
+(define XK:Greek-mu 2028)
+(define XK:Greek-nu 2029)
+(define XK:Greek-xi 2030)
+(define XK:Greek-omicron 2031)
+(define XK:Greek-pi 2032)
+(define XK:Greek-rho 2033)
+(define XK:Greek-sigma 2034)
+(define XK:Greek-finalsmallsigma 2035)
+(define XK:Greek-tau 2036)
+(define XK:Greek-upsilon 2037)
+(define XK:Greek-phi 2038)
+(define XK:Greek-chi 2039)
+(define XK:Greek-psi 2040)
+(define XK:Greek-omega 2041)
+(define XK:Greek-switch 65406)
+(define XK:EcuSign 8352)
+(define XK:ColonSign 8353)
+(define XK:CruzeiroSign 8354)
+(define XK:FFrancSign 8355)
+(define XK:LiraSign 8356)
+(define XK:MillSign 8357)
+(define XK:NairaSign 8358)
+(define XK:PesetaSign 8359)
+(define XK:RupeeSign 8360)
+(define XK:WonSign 8361)
+(define XK:NewSheqelSign 8362)
+(define XK:DongSign 8363)
+(define XK:EuroSign 8364)
diff --git a/mkimpcat.scm b/mkimpcat.scm
index 57c29b0..f94f949 100644
--- a/mkimpcat.scm
+++ b/mkimpcat.scm
@@ -15,50 +15,57 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
 ;;;; "mkimpcat.scm" Build SCM-specific catalog for SLIB.
 ;;; Author: Aubrey Jaffer.
 
-(let ((catname "implcat"))
-  (call-with-output-file (in-vicinity (implementation-vicinity) catname)
+(let ((catname "implcat")
+      (iv (implementation-vicinity)))
+  (define (in-implementation-vicinity . paths) (apply in-vicinity iv paths))
+  (call-with-output-file (in-implementation-vicinity catname)
     (lambda (op)
       (define (display* . args)
 	(for-each (lambda (arg) (display arg op)) args)
 	(newline op))
-      (define wb:vicinity (string-append (implementation-vicinity) "../wb/"))
-      (define x-scm:vicinity
-	(string-append (implementation-vicinity) "../xscm-2.01/"))
-      (define (add-link feature ofile . libs)
-	(cond ((file-exists? ofile)
-	       ;; 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))))))
+      (define (in-wb-vicinity . paths) (apply in-vicinity iv "../wb/" paths))
+      (define (in-xscm-vicinity . paths) (apply in-vicinity iv "../xscm-2.01/" paths))
+      (define (add-link feature . libs)
+	(define syms '())
+	;; remove #f from libs list
+	(set! libs (let rem ((l libs))
+		     (cond ((null? l) l)
+			   ((symbol? (car l))
+			    (set! syms (cons (car l) syms))
+			    (rem (cdr l)))
+			   ((car l) (cons (car l) (rem (cdr l))))
+			   (else (rem (cdr l))))))
+	(cond ((file-exists? (car libs))
 	       (display " " op)
-	       (write (cons feature (cons 'compiled (cons ofile libs))) op)
+	       (write
+		(cons feature (cons 'compiled (append syms libs)))
+		op)
 	       (newline op)
 	       #t)
 	      (else #f)))
@@ -72,95 +79,86 @@
 	(display* "(")
 	(begin
 	  (cond ((add-link 'i/o-extensions
-			   (in-vicinity (implementation-vicinity) "ioext"
-					link:able-suffix)
+			   (in-implementation-vicinity "ioext" link:able-suffix)
 			   (usr:lib "c"))
 		 (add-alias 'directory-for-each 'i/o-extensions)
 		 (add-alias 'line-i/o 'i/o-extensions)
 		 (add-alias 'pipe 'i/o-extensions)))
 	  (cond ((add-link 'rev2-procedures
-			   (in-vicinity (implementation-vicinity) "sc2"
-					link:able-suffix))
-		 (add-alias  'rev3-procedures 'rev2-procedures)))
+			   (in-implementation-vicinity "sc2"
+						       link:able-suffix))))
 	  (cond ((or
 		  (add-link 'db
-			    (in-vicinity wb:vicinity "db.so"))
+			    (in-wb-vicinity "db.so"))
 		  (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)
+			    (in-wb-vicinity "db" link:able-suffix)
+			    (in-wb-vicinity "handle" link:able-suffix)
+			    (in-wb-vicinity "blink" link:able-suffix)
+			    (in-wb-vicinity "prev" link:able-suffix)
+			    (in-wb-vicinity "ent" link:able-suffix)
+			    (in-wb-vicinity "sys" link:able-suffix)
+			    (in-wb-vicinity "del" link:able-suffix)
+			    (in-wb-vicinity "stats" link:able-suffix)
+			    (in-wb-vicinity "blkio" link:able-suffix)
+			    (in-wb-vicinity "scan" link:able-suffix)
 			    (usr:lib "c")))
 		 (add-source 'wb-table
-			     (in-vicinity wb:vicinity "wbtab"))
+			     (in-wb-vicinity "wbtab"))
 		 (add-alias 'wb 'db)))
+	  (cond ((add-link 'mysql
+			   (in-implementation-vicinity "database"
+						       link:able-suffix)
+			   ;;(usr:lib "mysqlclient") ;?
+			   )))
 	  (cond ((add-link 'stringvector
-			   (in-vicinity x-scm:vicinity "strvec" link:able-suffix))
-		 (add-source 'x11   (in-vicinity x-scm:vicinity "x11"))
-		 (add-source 'xevent(in-vicinity x-scm:vicinity "xevent"))
-		 (add-source 'xt    (in-vicinity x-scm:vicinity "xt"))
-		 (add-source 'xm    (in-vicinity x-scm:vicinity "xm"))
-		 (add-source 'xmsubs(in-vicinity x-scm:vicinity "xmsubs"))
-		 (add-source 'xaw   (in-vicinity x-scm:vicinity "xaw"))
-		 (add-source 'xpm   (in-vicinity x-scm:vicinity "xpm"))))
+			   (in-xscm-vicinity "strvec" link:able-suffix))
+		 (add-source 'x11   (in-xscm-vicinity "x11"))
+		 (add-source 'xevent(in-xscm-vicinity "xevent"))
+		 (add-source 'xt    (in-xscm-vicinity "xt"))
+		 (add-source 'xm    (in-xscm-vicinity "xm"))
+		 (add-source 'xmsubs(in-xscm-vicinity "xmsubs"))
+		 (add-source 'xaw   (in-xscm-vicinity "xaw"))
+		 (add-source 'xpm   (in-xscm-vicinity "xpm"))))
 
 	  (add-link 'turtle-graphics
-		    (in-vicinity (implementation-vicinity) "turtlegr"
-				 link:able-suffix)
+		    (in-implementation-vicinity "turtlegr" link:able-suffix)
 		    (x:lib "X11")
 		    (usr:lib "m")
 		    (usr:lib "c"))
 	  (add-link 'Xlib
-		    (in-vicinity (implementation-vicinity) "x"
-				 link:able-suffix)
+		    (in-implementation-vicinity "x" link:able-suffix)
 		    (x:lib "X11")
 		    (usr:lib "c"))
 	  (add-link 'curses
-		    (in-vicinity (implementation-vicinity) "crs"
-				 link:able-suffix)
+		    (in-implementation-vicinity "crs" link:able-suffix)
 		    (usr:lib "ncurses")
 		    ;;(usr:lib "curses")
 		    ;;(usr:lib "termcap")
 		    (usr:lib "c"))
 	  (add-link 'edit-line
-		    (in-vicinity (implementation-vicinity) "edline"
-				 link:able-suffix)
+		    (in-implementation-vicinity "edline" link:able-suffix)
 		    (usr:lib "readline")
 		    (usr:lib "termcap")
 		    (usr:lib "c"))
 	  (add-link 'regex
-		    (in-vicinity (implementation-vicinity) "rgx"
-				 link:able-suffix)
+		    (in-implementation-vicinity "rgx" link:able-suffix)
 		    (usr:lib "c"))
 	  (add-link 'unix
-		    (in-vicinity (implementation-vicinity) "unix"
-				 link:able-suffix)
-		    (in-vicinity (implementation-vicinity) "ioext"
-				 link:able-suffix)
+		    'i/o-extensions
+		    (in-implementation-vicinity "unix" link:able-suffix)
 		    (usr:lib "c"))
 	  (add-link 'posix
-		    (in-vicinity (implementation-vicinity) "posix"
-				 link:able-suffix)
+		    (in-implementation-vicinity "posix" link:able-suffix)
 		    (usr:lib "c"))
 	  (add-link 'socket
-		    (in-vicinity (implementation-vicinity) "socket"
-				 link:able-suffix)
+		    (in-implementation-vicinity "socket" link:able-suffix)
 		    (usr:lib "c"))
 	  (add-link 'record
-		    (in-vicinity (implementation-vicinity) "record"
-				 link:able-suffix))
+		    (in-implementation-vicinity "record" link:able-suffix))
 	  (add-link 'generalized-c-arguments
-		    (in-vicinity (implementation-vicinity) "gsubr"
-				 link:able-suffix))
+		    (in-implementation-vicinity "gsubr" link:able-suffix))
 	  (add-link 'array-for-each
-		    (in-vicinity (implementation-vicinity) "ramap"
-				 link:able-suffix))
+		    (in-implementation-vicinity "ramap" link:able-suffix))
 	  )
 	(display* ")")
 	)
@@ -180,21 +178,19 @@
       (begin
 	;; Simple associations -- OK for all modes of dynamic-linking
 	(display* "(")
-	(add-alias 'hobbit (in-vicinity (implementation-vicinity) "hobbit"))
-	(add-alias 'scmhob (in-vicinity (implementation-vicinity) "scmhob"))
-	(add-alias 'regex-case
-		    (in-vicinity (implementation-vicinity) "rgxcase"))
-	(add-alias 'url-filename
-		    (in-vicinity (implementation-vicinity) "urlfile"))
-	(add-source 'disarm (in-vicinity
-			     (implementation-vicinity)
+	(add-alias '2rs 'r2rs)
+	(add-alias '3rs 'r3rs)
+	(add-alias '4rs 'r4rs)
+	(add-alias '5rs 'r5rs)
+	(add-alias 'hobbit (in-implementation-vicinity "hobbit"))
+	(add-alias 'scmhob (in-implementation-vicinity "scmhob"))
+	(add-alias 'regex-case (in-implementation-vicinity "rgxcase"))
+	(add-alias 'url-filename (in-implementation-vicinity "urlfile"))
+	(add-source 'disarm (in-implementation-vicinity
 			     (string-append "disarm" (scheme-file-suffix))))
-	(add-source 'build (in-vicinity
-			    (implementation-vicinity)
-			    (string-append "build" (scheme-file-suffix))))
-
-	;; (add-alias 'impl:callback '(identity))
-
+	(add-source 'build (in-implementation-vicinity "build"))
+	(add-source 'compile (in-implementation-vicinity
+			      (string-append "compile" (scheme-file-suffix))))
 	(display* ")")
 	)
 
@@ -203,7 +199,7 @@
 	(display* "#.(if (defined? renamed-identifier)")
 	(display* "      '(")
 	(display "       " op)
-	(add-source 'macro (in-vicinity (implementation-vicinity) "Macro"))
+	(add-source 'macro (in-implementation-vicinity "Macro"))
 	(display* "        )")
 	(display* "      '())")
 	)
diff --git a/patchlvl.h b/patchlvl.h
index ac7f137..7dc9724 100644
--- a/patchlvl.h
+++ b/patchlvl.h
@@ -4,11 +4,11 @@
  #  for alpha release, "b" for beta release, "c", and so on), and the
  #  trailing number is the patchlevel. */
  #  /* This next line sets VERSION when included from the Makefile */
-VERSION=5d2
+VERSION=5d6
 #endif
 
 #ifndef SCMVERSION
-# define SCMVERSION "5d2"
+# define SCMVERSION "5d6"
 #endif
 #ifdef nosve
 # define INIT_FILE_NAME "Init"SCMVERSION"_scm";
diff --git a/posix.c b/posix.c
index cf3a0fa..8af5c0b 100644
--- a/posix.c
+++ b/posix.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -60,11 +60,14 @@
 # else
 #  ifdef linux
 #    include <unistd.h>
+#  else
+#   ifdef __OpenBSD__
+#    include <unistd.h>
+#   endif
 #  endif
 # endif
 #endif
 
-     /* Only the superuser can successfully execute this call */
 static char s_chown[] = "chown";
 SCM l_chown(path, owner, group)
      SCM path, owner, group;
@@ -94,6 +97,7 @@ SCM l_pipe()
   FILE *f_rd, *f_wt;
   SCM p_rd, p_wt;
   NEWCELL(p_rd); NEWCELL(p_wt);
+  DEFER_INTS;
   SYSCALL(ret = pipe(fd););
   if (ret) {ALLOW_INTS; return BOOL_F;}
   SYSCALL(f_rd = fdopen(fd[0], "r"););
@@ -108,10 +112,8 @@ SCM l_pipe()
     close(fd[1]);
     wta(UNDEFINED, (char *)NALLOC, s_port_type);
   }
-  CAR(p_rd) = scm_port_entry(tc16_fport, mode_bits("r", (char *)0));
-  CAR(p_wt) = scm_port_entry(tc16_fport, mode_bits("w", (char *)0));
-  SETSTREAM(p_rd, f_rd);
-  SETSTREAM(p_wt, f_wt);
+  p_rd = scm_port_entry(f_rd, tc16_fport, mode_bits("r", (char *)0));
+  p_wt = scm_port_entry(f_wt, tc16_fport, mode_bits("w", (char *)0));
   ALLOW_INTS;
   return cons(p_rd, p_wt);
 }
@@ -123,24 +125,18 @@ SCM open_pipe(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);
+	ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_op_pipe);
 	NEWCELL(z);
 	/* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/
 	DEFER_INTS;
 	ignore_signals();
 	SCM_OPENCALL(f = popen(CHARS(pipestr), CHARS(modes)));
 	unignore_signals();
-	if (!f) {
-	  ALLOW_INTS;
-	  return BOOL_F;
-	}
-	else {
-	  CAR(z) = scm_port_entry(tc16_pipe,
-			  OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG));
-	  SETSTREAM(z, f);
-	}
+	z = f ?
+	  scm_port_entry(f, tc16_pipe,
+			 OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG)) :
+	  BOOL_F;
 	ALLOW_INTS;
-	SCM_PORTDATA(z) = pipestr;
 	return z;
 }
 
@@ -156,8 +152,9 @@ SCM scm_getgroups()
      strings are now checked for null termination during gc.
      The length needs not be exactly right */
   grps = must_malloc_cell((0L + ngroups) * sizeof(gid_t),
-	  MAKE_LENGTH(((0L + ngroups) * sizeof(gid_t))/sizeof(long), tc7_uvect),
-	  scm_s_getgroups);
+			  MAKE_LENGTH(((0L + ngroups) * sizeof(gid_t))/sizeof(long),
+				      tc7_uvect),
+			  scm_s_getgroups);
   ALLOW_INTS;
   {
     gid_t *groups = (gid_t *)CHARS(grps);
@@ -261,6 +258,10 @@ SCM l_getppid()
   return MAKINUM(0L+getppid());
 }
 
+SCM scm_getlogin()
+{
+  return makfrom0str(getlogin());
+}
 SCM l_getuid()
 {
   return MAKINUM(0L+getuid());
@@ -350,6 +351,7 @@ static iproc subr0s[] = {
 	{"pipe", l_pipe},
 	{scm_s_getgroups, scm_getgroups},
 	{"getppid", l_getppid},
+	{"getlogin", scm_getlogin},
 	{"getuid", l_getuid},
 	{"getgid", l_getgid},
 #ifndef LACK_E_IDs
@@ -403,5 +405,8 @@ void init_posix()
 	scm_ldstr("\n\
 (define (open-input-pipe cmd) (open-pipe cmd \"r\"))\n\
 (define (open-output-pipe cmd) (open-pipe cmd \"w\"))\n\
+(define getlogin\n\
+  (let ((getlogin getlogin))\n\
+    (lambda () (or (getlogin) (getenv \"USER\") (getenv \"LOGNAME\")))))\n\
 ");
 }
diff --git a/r4rstest.scm b/r4rstest.scm
index bc3f2f7..3683f0d 100644
--- a/r4rstest.scm
+++ b/r4rstest.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 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
@@ -184,9 +184,11 @@
 (test 34 'letrec x)
 (test 10 'letrec (letrec ((x 3)) (define x 10) x))
 (test 34 'letrec x)
+(define (s x) (if x (let () (set! s x) (set! x s))))
 (SECTION 4 2 3)
 (define x 0)
-(test 6 'begin (begin (set! x 5) (+ x 1)))
+(test 6 'begin (begin (set! x (begin (begin 5)))
+		      (begin ((begin +) (begin x) (begin (begin 1))))))
 (SECTION 4 2 4)
 (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
 			    (i 0 (+ i 1)))
@@ -241,16 +243,31 @@
 (define first car)
 (test 1 'define (first '(1 2)))
 (define old-+ +)
-(define + (lambda (x y) (list y x)))
-(test '(3 6) add3 6)
+(begin (begin (begin)
+	      (begin (begin (begin) (define + (lambda (x y) (list y x)))
+			    (begin)))
+	      (begin))
+       (begin)
+       (begin (begin (begin) (test '(3 6) add3 6)
+		     (begin))))
 (set! + old-+)
 (test 9 add3 6)
+(begin)
+(begin (begin))
+(begin (begin (begin (begin))))
 (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))))
+      (let ((x 5))
+	(begin (begin (begin)
+		      (begin (begin (begin) (define foo (lambda (y) (bar x y)))
+				    (begin)))
+		      (begin))
+	       (begin)
+	       (begin)
+	       (begin (define bar (lambda (a b) (+ (* a b) a))))
+	       (begin))
+	(begin)
+	(begin (foo (+ x 3)))))
 (define x 34)
 (define (foo) (define x 5) x)
 (test 5 foo)
@@ -523,6 +540,8 @@
 (test 1 remainder 13 -4)
 (test -1 modulo -13 -4)
 (test -1 remainder -13 -4)
+(test 0 modulo 0 86400)
+(test 0 modulo 0 -86400)
 (define (divtest n1 n2)
 	(= n1 (+ (* n2 (quotient n1 n2))
 		 (remainder n1 n2))))
@@ -551,7 +570,6 @@
   (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; ")
@@ -571,20 +589,21 @@
   (test f4.0 round f4.5)
   (test 1 expt 0 0)
   (test 0 expt 0 1)
+  (test (atan 1) atan 1 1)
   (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)
+	(display #\; test-file)
+	(display ";" test-file)
+	(write 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")))
@@ -707,13 +726,29 @@
   (test 0 modulo 2177452800 -86400)
   (test 0 modulo 2177452800 86400)
   (test 0 modulo -2177452800 -86400)
+  (test 0 modulo  0 -2177452800)
   (test #t 'remainder (tb 281474976710655325431 65535))
   (test #t 'remainder (tb 281474976710655325430 65535))
+
   (SECTION 6 5 8)
   (test 281474976710655325431 string->number "281474976710655325431")
   (test "281474976710655325431" number->string 281474976710655325431)
   (report-errs))
 
+(define (test-numeric-predicates)
+  (let* ((big-ex (expt 2 90))
+	 (big-inex (exact->inexact big-ex)))
+    (newline)
+    (display ";testing bignum-inexact comparisons;")
+    (newline)
+    (SECTION 6 5 5)
+    (test #f = (+ big-ex 1) big-inex (- big-ex 1))
+    (test #f = big-inex (+ big-ex 1) (- big-ex 1))
+    (test #t < (- (inexact->exact big-inex) 1)
+	  big-inex
+	  (+ (inexact->exact big-inex) 1))))
+
+
 (SECTION 6 5 9)
 (test "0" number->string 0)
 (test "100" number->string 100)
@@ -734,6 +769,10 @@
 (test #f string->number "3.3I")
 (test #f string->number "-")
 (test #f string->number "+")
+(test #t 'string->number (or (not (string->number "80000000" 16))
+			     (positive? (string->number "80000000" 16))))
+(test #t 'string->number (or (not (string->number "-80000000" 16))
+			     (negative? (string->number "-80000000" 16))))
 
 (SECTION 6 6)
 (test #t eqv? '#\  #\Space)
@@ -980,6 +1019,9 @@
 
 (test '(b e h) map cadr '((a b) (d e) (g h)))
 (test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '(1 2 3) map + '(1 2 3))
+(test '(1 2 3) map * '(1 2 3))
+(test '(-1 -2 -3) map - '(1 2 3))
 (test '#(0 1 4 9 16) 'for-each
 	(let ((v (make-vector 5)))
 		(for-each (lambda (i) (vector-set! v i (* i i)))
@@ -1097,21 +1139,23 @@
 	    (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 #\; read-char test-file)
+  (test #\; read-char test-file)
+  (test write-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)))
+  '(#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)
+	(display #\; test-file)
+	(display ";" test-file)
+	(write write-test-obj test-file)
 	(newline test-file)
 	(write load-test-obj test-file)
 	(output-port? test-file)))
@@ -1119,7 +1163,9 @@
 
 (define test-file (open-output-file "tmp2"))
 (write-char #\; test-file)
-(display write-test-obj test-file)
+(display #\; test-file)
+(display ";" test-file)
+(write write-test-obj test-file)
 (newline test-file)
 (write load-test-obj test-file)
 (test #t output-port? test-file)
@@ -1145,13 +1191,18 @@
   (report-errs))
 
 (report-errs)
-(cond ((and (string->number "0.0") (inexact? (string->number "0.0")))
-       (test-inexact)
-       (test-inexact-printing)))
+(let ((have-inexacts? 
+       (and (string->number "0.0") (inexact? (string->number "0.0"))))
+      (have-bignums?
+       (let ((n (string->number "281474976710655325431")))
+	 (and n (exact? n)))))
+  (cond (have-inexacts?
+	 (test-inexact)
+	 (test-inexact-printing)))
+  (if have-bignums? (test-bignum))
+  (if (and have-inexacts? have-bignums?)
+      (test-numeric-predicates)))
 
-(let ((n (string->number "281474976710655325431")))
-  (if (and n (exact? n))
-      (test-bignum)))
 (newline)
 (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
 (newline)
diff --git a/ramap.c b/ramap.c
index caf220f..08ba177 100644
--- a/ramap.c
+++ b/ramap.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -115,7 +115,7 @@ int ra_matchp(ra0, ras)
     ra1 = CAR(ras);
     switch (IMP(ra1) ? 0 : TYP7(ra1)) {
     default: scalar:
-      CAR(ras) = sc2array(ra1,ra0,EOL); break;
+      CAR(ras) = sc2array(ra1, ra0, EOL); break;
     case tc7_vector:
     case tcs_uves:
       if (1 != ndim) return 0;
@@ -304,11 +304,11 @@ static int racp(src, dst)
     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;
+  case tc7_string: if (tc7_string != TYP7(src)) 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;
+  case tc7_bvect: if (tc7_bvect != TYP7(src)) 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);
@@ -502,7 +502,7 @@ SCM ura_write(ra, port)
      SCM ra, port;
 {
   if (NIMP(ra) && ARRAYP(ra))
-    return uve_write(ra2contig(ra,1), port);
+    return uve_write(ra2contig(ra, 1), port);
   else
     return uve_write(ra, port);
 }
@@ -1081,7 +1081,7 @@ static int ramap(ra0, proc, ras)
   if (argc >= 5) {
     heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
     rav = VELTS(heap_ve);
-    argv = &(rav[n]);
+    argv = &(rav[argc]);
   }
   for (k = 0; k < argc; k++) {
     rav[k] = CAR(ras);
@@ -1276,23 +1276,22 @@ SCM array_map(ra0, proc, lra)
      SCM ra0, proc, lra;
 {
   long narg = ilength(lra);
-  ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_map);
  tail:
+#ifndef RECKLESS
+    scm_arity_check(proc, narg, s_array_map);
+#endif
   switch TYP7(proc) {
-  wna: wta(UNDEFINED, (char *)WNA, s_array_map);
   default: gencase:
-    ASRTGO(scm_arity_check(proc, narg, s_array_map), wna);
     ramapc(ramap, proc, ra0, lra, s_array_map);
     return UNSPECIFIED;
-  case tc7_subr_1: ASRTGO(1==narg, wna);
+  case tc7_subr_1:
     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);
+  case tc7_subr_2:
+  case tc7_subr_2o:
     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: {
@@ -1361,8 +1360,9 @@ SCM array_map(ra0, proc, lra)
 #if 1 /* def CCLO */
   case tc7_specfun:
     if (tc16_cclo==TYP16(proc)) {
-      lra = cons(sc2array(proc,ra0,EOL), lra);
+      lra = cons(sc2array(proc, ra0, EOL), lra);
       proc = CCLO_SUBR(proc);
+      narg++;
       goto tail;
     }
     goto gencase;
@@ -1381,7 +1381,7 @@ static int rafe(ra0, proc, ras)
   if (argc >= 5) {
     heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
     rav = VELTS(heap_ve);
-    argv = &(rav[n]);
+    argv = &(rav[argc]);
   }
   rav[0] = ra0;
   for (k = 1; k < argc; k++) {
@@ -1402,7 +1402,6 @@ SCM array_for_each(proc, ra0, lra)
      SCM proc, ra0, lra;
 {
   long narg = ilength(lra) + 1;
-  ASSERT(BOOL_T==procedurep(proc), proc, ARG1, s_array_for_each);
  tail:
 #ifndef RECKLESS
   scm_arity_check(proc, narg, s_array_for_each);
@@ -1435,7 +1434,6 @@ SCM array_imap(ra, proc)
   long *indv = &auto_indv[0];
   sizet i;
   ASSERT(NIMP(ra), ra, ARG1, s_array_imap);
-  ASSERT(BOOL_T==procedurep(proc), proc, ARG2, s_array_imap);
   i = INUM(array_rank(ra));
 #ifndef RECKLESS
     scm_arity_check(proc, i+0L, s_array_imap);
@@ -1676,7 +1674,7 @@ void init_ramap()
   add_feature(s_array_for_each);
 scm_ldstr("\n\
 (define (array-indexes ra)\n\
-  (let ((ra0 (apply make-array '() (array-shape ra))))\n\
+  (let ((ra0 (apply create-array '#() (array-shape ra))))\n\
     (array-index-map! ra0 list)\n\
     ra0))\n\
 ");
diff --git a/record.c b/record.c
index 585c920..6811575 100644
--- a/record.c
+++ b/record.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -130,18 +130,19 @@ SCM rec_constr(rtd, flds)
     while (i--) REC_IND_SET(indices, i, i+1);
   }
   else {
-    ASSERT(NIMP(flds) && CONSP(flds), flds, ARG2, s_rec_constr);
-    indices = MAKE_REC_INDS(ilength(flds));
+    i = ilength(flds);
+    ASSERT(i>=0, flds, ARG2, s_rec_constr);
+    indices = MAKE_REC_INDS(i);
     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)) {
+	ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
 	if (fld==CAR(flst)) {
 	  REC_IND_SET(indices, i, j+1);
 	  break;
 	}
-	ASSERT(NNULLP(flst), fld, ARG2, s_rec_constr);
       }
     }
   }
@@ -165,7 +166,7 @@ static void rec_error(arg, pos, what, rtd, i)
   }
   else
     mesg = st_append(cons2(mesg, recname, EOL));
-  everr(UNDEFINED, EOL, arg, pos, CHARS(mesg));
+  wta(arg, pos, CHARS(mesg));
 }
 #endif
 static char s_rec_constr1[] = "record constructor: ";
@@ -259,9 +260,9 @@ SCM makrectyp(name, fields)
 {
   SCM n, argv[2];
 #ifndef RECKLESS
-  if(ilength(fields) < 0)
+  if (ilength(fields) < 0)
   errout: wta(fields, (char *)ARG2, s_makrectyp);
-  for (n=fields; NIMP(n); n = CDR(n))
+  for (n = fields; NIMP(n); n = CDR(n))
     if (!SYMBOLP(CAR(n))) goto errout;
 #endif
   argv[0] = name;
@@ -274,7 +275,7 @@ SCM rec_prinset(rtd, printer)
      SCM rtd, printer;
 {
   ASSERT(NIMP(rtd) && RTDP(rtd), rtd, ARG1, s_rec_prinset);
-  ASSERT(BOOL_F==printer || scm_arity_check(printer, 2L, (char *)0),
+  ASSERT(BOOL_F==printer || scm_arity_check(printer, 3L, (char *)0),
 	 printer, ARG2, s_rec_prinset);
   RTD_PRINTER(rtd) = printer;
   return UNSPECIFIED;
@@ -291,7 +292,7 @@ static SCM markrec(ptr)
 static sizet freerec(ptr)
      CELLPTR ptr;
 {
-  must_free(CHARS(ptr), sizeof(SCM)*NUMDIGS(ptr));
+  must_free(CHARS((SCM)ptr), sizeof(SCM)*NUMDIGS((SCM)ptr));
   return 0;
 }
 static int recprin1(exp, port, writing)
@@ -299,16 +300,30 @@ static int recprin1(exp, port, writing)
      int writing;
 {
   SCM names, printer = RTD_PRINTER(REC_RTD(exp));
+  SCM argv[3];
   sizet i;
   if NIMP(printer) {
-    SCM argv[2];
     argv[0] = exp;
     argv[1] = port;
-    return scm_cvapply(printer, 2L, argv);
+    argv[2] = writing ? BOOL_T : BOOL_F;
+    /* A writing value of 2 means we are printing an error message.
+       An error in a record printer at this time will result in a
+       fatal recursive error. */
+    if (2 != writing) {
+      if (NFALSEP(scm_cvapply(printer, 3L, argv)))
+	return 1;
+    }
+    else {
+      lputs("\n; Ignoring record-printer: ", cur_errp);
+    }
   }
   names = RTD_FIELDS(REC_RTD(exp));
   lputs("#s(", port);
   iprin1(RTD_NAME(REC_RTD(exp)), port, 0);
+  if (writing) {
+    lputc(':', port);
+    intprint(((long)REC_RTD(exp))>>1, 16, port);
+  }
   for (i = 1; i < NUMDIGS(exp); i++) {
     lputc(' ', port);
     iprin1(CAR(names), port, 0);
@@ -329,6 +344,24 @@ static int recprin1(exp, port, writing)
 */
   return 1;
 }
+
+static SCM f_rtdprin1;
+SCM rec_rtdprin1(rtd, port, writing_p)
+     SCM rtd, port, writing_p;
+{
+  lputs("#s(record-type ", port);
+  iprin1(RTD_NAME(rtd), port, 0);
+  lputc(':', port);
+  intprint(((long)rtd)>>1, 16, port);
+  lputs(" fields ", port);
+  iprin1(RTD_FIELDS(rtd), port, 0);
+  if (NIMP(RTD_PRINTER(rtd)))
+    lputs(" P)", port);
+  else
+    lputc(')', port);
+  return BOOL_T;
+}
+
 SCM recequal(rec0, rec1)
      SCM rec0, rec1;
 {
@@ -360,13 +393,14 @@ void init_record()
   SCM the_rtd, rtd_name = makfrom0str("record-type");
   SCM rtd_fields = cons2(i_name, i_fields, cons(i_printer, EOL));
   tc16_record = newsmob(&recsmob);
+  f_rtdprin1 = make_subr(" rtdprin1", tc7_subr_3, rec_rtdprin1);
   DEFER_INTS;
   the_rtd = must_malloc_cell(4L * sizeof(SCM),
 		 MAKE_NUMDIGS(4L, tc16_record), s_record);
   REC_RTD(the_rtd) = the_rtd;
   RTD_NAME(the_rtd) = rtd_name;
   RTD_FIELDS(the_rtd) = rtd_fields;
-  RTD_PRINTER(the_rtd) = BOOL_F;
+  RTD_PRINTER(the_rtd) = f_rtdprin1;
   ALLOW_INTS;
   the_rtd_rtd = the_rtd;	/* Protected by make-record-type */
   f_rec_pred1 = make_subr(" record-predicate-procedure", tc7_subr_2, rec_pred1);
diff --git a/repl.c b/repl.c
index 20be8b1..ae7642f 100644
--- a/repl.c
+++ b/repl.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990-1999 Free Software Foundation, Inc.
+/* Copyright (C) 1990-2002 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
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -53,6 +53,15 @@ void	scm_fill_freelist P((void));
 # include <sys/types.h>
 #endif
 
+#ifdef __OpenBSD__
+# include <ctype.h>
+# include <unistd.h>
+#endif
+
+#ifdef PLAN9
+# include <ctype.h>
+#endif
+
 #ifdef ARM_ULIB
 # include <termio.h>
 int set_erase()
@@ -62,7 +71,7 @@ int set_erase()
    ioctl(0, TCGETA, &tin);
    tin.c_cc[VERASE] = '\010';
 
-   ioctl(0, TCSETA,&tin);
+   ioctl(0, TCSETA, &tin);
    return(0);
 }
 #endif
@@ -122,8 +131,11 @@ char *isymnames[] = {
 				/*  NUM_ISPCSYMS ISPCSYMS here */
   "#@and", "#@begin", "#@case", "#@cond", "#@do", "#@if", "#@lambda",
   "#@let", "#@let*", "#@letrec", "#@or", "#@quote", "#@set!",
-  "#@define", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
-  "#@quasiquote", "#@unquote", "#@unquote-splicing", "#@else", "#@=>",
+  "#@funcall", "#@apply", "#@farloc-car", "#@farloc-cdr", "#@delay",
+  "#@quasiquote", "#@eval-for-apply", "#@let-syntax", "#@acro-call",
+  "#<line>",  "#@define",
+  "#@unquote", "#@unquote-splicing", "#@else", "#@=>", "#@values-token",
+  "#@keyword",
 				/* user visible ISYMS */
 				/* other keywords */
 				/* Flags */
@@ -138,9 +150,13 @@ static char	s_freshline[] = "freshline";
 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 SCM lread1 P((SCM port, int nump, char *what));
+static SCM lreadr P((SCM tok_buf, SCM port, int nump));
+static SCM lreadpr P((SCM tok_buf, SCM port, int nump));
+static SCM lreadparen P((SCM tok_buf, SCM port, int nump, char *name));
+static SCM lread_rec P((SCM tok_buf, SCM port));
 static sizet read_token P((int ic, SCM tok_buf, SCM port));
+static void err_head P((char *str));
 
 void intprint(n, radix, port)
      long n;
@@ -196,7 +212,7 @@ void iprlist(hdr, exp, tlr, port, writing)
 void iprin1(exp, port, writing)
      SCM exp;
      SCM port;
-int writing;
+     int writing;
 {
   register long i;
 taloop:
@@ -219,6 +235,11 @@ taloop:
 	intprint(i, -8, port);
       else lputc((int)i, port);
     }
+    else if (SCM_LINUMP(exp)) {
+      lputs("#<line ", port);
+      intprint(SCM_LINUM(exp), -10, port);
+      lputc('>', port);
+    }
     else if (IFLAGP(exp) && (ISYMNUM(exp)<(sizeof isymnames/sizeof(char *))))
       lputs(ISYMCHARS(exp), port);
     else if ILOCP(exp) {
@@ -247,14 +268,29 @@ taloop:
       break;
     }
     switch TYP7(exp) {
+    case (127 & IM_LET):
+      if (CAR(exp) != IM_LET) {
+	lputs("(#@call ", port);
+	exp = CDR(exp);
+	iprin1(CAR(exp), port, writing);
+	iprlist(" ", CAR(CDR(exp)), ')', port, writing);
+	break;
+      }
+      /* else fall through */
+    case (127 & IM_AND): case (127 & IM_BEGIN): case (127 & IM_CASE):
+    case (127 & IM_COND): case (127 & IM_DO): case (127 & IM_IF):
+    case (127 & IM_LAMBDA): case (127 & IM_LETSTAR):
+    case (127 & IM_LETREC): case (127 & IM_OR): case (127 & IM_QUOTE):
+    case (127 & IM_SET): case (127 & IM_FUNCALL):
+    case tcs_cons_inum:
+    case tcs_cons_iloc:
+    case tcs_cons_chflag:
     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);
+      scm_princlosure(exp, port, writing);
       break;
     case tc7_string:
       if (writing) {
@@ -363,7 +399,9 @@ static int input_waiting(f)
 #    else
 #     ifndef macintosh
 #      ifndef ARM_ULIB
-#       include <sys/ioctl.h>
+#       ifndef PLAN9
+#        include <sys/ioctl.h>
+#       endif
 #      endif
 #     endif
 #    endif
@@ -408,7 +446,7 @@ SCM char_readyp(port)
      SCM port;
 {
   if UNBNDP(port) port = cur_inp;
-  else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
+  ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_char_readyp);
   if (CRDYP(port) || !(BUF0 & SCM_PORTFLAGS(port))) return BOOL_T;
   return input_waiting(STREAM(port)) ? BOOL_T : BOOL_F;
 }
@@ -417,7 +455,11 @@ SCM char_readyp(port)
 # include <pc.h>
 #endif
 #ifndef HAVE_SELECT
-# include <time.h>
+# ifdef PLAN9
+#  define kbhit() 0
+# else
+#  include <time.h>
+# endif
 #endif
 #ifdef __STDC__
 # define timet time_t
@@ -520,11 +562,46 @@ SCM eof_objectp(x)
 	return (EOF_VAL==x) ? BOOL_T : BOOL_F;
 }
 
+static SCM *loc_broken_pipe = 0;
+/* returning non-zero means try again. */
+int scm_io_error(port, what)
+     SCM port;
+     char *what;
+{
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+  if (EPIPE==errno) {
+    if (verbose > 2) {
+      err_head("WARNING");
+      lputs(";;", cur_errp);
+      lputs(what, cur_errp);
+      lputs(": closing pipe ", cur_errp);
+      iprin1(port, cur_errp, 1);
+      newline(cur_errp);
+    }
+    close_port(port);
+    if (*loc_broken_pipe && NIMP(*loc_broken_pipe))
+      apply(*loc_broken_pipe, port, listofnull);
+    return 0;
+  }
+# endif
+#endif
+  if (SCM_INTERRUPTED(errno)) {
+    errno = 0;
+    return !0;
+  }
+  wta(port, what, "Input/Output");
+  return 0;			/* squelch warning */
+}
+
+static char s_fflush[] = "fflush";
 void lfflush(port)		/* internal SCM call */
      SCM port;
 {
   sizet i = PTOBNUM(port);
-  (ptobs[i].fflush)(STREAM(port));
+  while ((ptobs[i].fflush)(STREAM(port)) &&
+	 scm_io_error(port, s_fflush))
+    ;
 }
 static char	s_flush[] = "force-output";
 SCM lflush(port)		/* user accessible as force-output */
@@ -534,7 +611,9 @@ SCM lflush(port)		/* user accessible as force-output */
 	else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_flush);
 	{
 	  sizet i = PTOBNUM(port);
-	  SYSCALL((ptobs[i].fflush)(STREAM(port)););
+	  while ((ptobs[i].fflush)(STREAM(port)) &&
+		 scm_io_error(port, s_fflush))
+	    ;
 	  return UNSPECIFIED;
 	}
 }
@@ -545,11 +624,6 @@ SCM lwrite(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)
@@ -558,11 +632,6 @@ SCM display(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)
@@ -571,13 +640,7 @@ SCM newline(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);
+	if (port==cur_outp) lfflush(port);
 	return UNSPECIFIED;
 }
 SCM write_char(chr, port)
@@ -587,11 +650,6 @@ SCM write_char(chr, port)
 	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;
 }
 SCM scm_freshline(port)
@@ -601,13 +659,7 @@ SCM scm_freshline(port)
 	else ASSERT(NIMP(port) && OPOUTPORTP(port), port, ARG1, s_freshline);
 	if (INUM0==scm_port_col(port)) return UNSPECIFIED;
 	lputc('\n', port);
-#ifdef HAVE_PIPE
-# ifdef EPIPE
-	if (EPIPE==errno) close_port(port);
-	else
-# endif
-#endif
-	  if (port==cur_outp) lfflush(port);
+	if (port==cur_outp) lfflush(port);
 	return UNSPECIFIED;
 }
 
@@ -616,13 +668,15 @@ void lputc(c, port)
      SCM port;
 {
   sizet i = PTOBNUM(port);
-  SYSCALL((ptobs[i].fputc)(c, STREAM(port)););
+  while (EOF==(ptobs[i].fputc)(c, STREAM(port)) &&
+	 scm_io_error(port, "fputc"))
+    ;
   if (CRDY & CAR(port)) {
     i = SCM_PORTNUM(port);
     switch (c) {
     case LINE_INCREMENTORS:
       scm_port_table[i].line++;
-      scm_port_table[i].col = 0;
+      scm_port_table[i].col = 1;
       break;
     default:
       scm_port_table[i].col++;
@@ -635,7 +689,9 @@ void lputs(s, port)
 {
   sizet i = PTOBNUM(port);
   ASSERT(s, INUM0, ARG1, "lputs");
-  SYSCALL((ptobs[i].fputs)(s, STREAM(port)););
+  while (EOF==(ptobs[i].fputs)(s, STREAM(port)) &&
+	 scm_io_error(port, "fputs"))
+    ;
   if (CRDY & CAR(port)) {
     sizet j;
     i = SCM_PORTNUM(port);
@@ -643,7 +699,7 @@ void lputs(s, port)
       switch (s[j]) {
       case LINE_INCREMENTORS:
 	scm_port_table[i].line++;
-	scm_port_table[i].col = 0;
+	scm_port_table[i].col = 1;
 	break;
       default:
 	scm_port_table[i].col++;
@@ -658,8 +714,9 @@ sizet lfwrite(ptr, size, nitems, port)
      SCM port;
 {
   sizet ret, i = PTOBNUM(port);
-  SYSCALL(ret = (ptobs[i].fwrite)
-	  (ptr, size, nitems, STREAM(port)););
+  do {
+    ret = (ptobs[i].fwrite)(ptr, size, nitems, STREAM(port));
+  }  while(nitems != ret && scm_io_error(port, "fwrite"));
   if (CRDY & CAR(port)) {
     sizet j;
     i = SCM_PORTNUM(port);
@@ -667,7 +724,7 @@ sizet lfwrite(ptr, size, nitems, port)
       switch (ptr[j]) {
       case LINE_INCREMENTORS:
 	scm_port_table[i].line++;
-	scm_port_table[i].col = 0;
+	scm_port_table[i].col = 1;
 	break;
       default:
 	scm_port_table[i].col++;
@@ -682,7 +739,7 @@ int lgetc(port)
 {
   FILE *f;
   int c;
-  sizet i, j;
+  int i, j = -1;
   if (CRDY & CAR(port)) {
     j = SCM_PORTNUM(port);
     c = scm_port_table[j].unread;
@@ -699,12 +756,13 @@ int lgetc(port)
 #else
   SYSCALL(c = (ptobs[i].fgetc)(f););
 #endif
-  if (CRDY & CAR(port)) {	/* CRDY overloaded !!*/
+  if (j > -1)  {
+    /* This means that CRDY is set, note that CRDY is overloaded */
     switch (c) {
     case LINE_INCREMENTORS:
       scm_port_table[j].line++;
       scm_port_table[j].colprev = scm_port_table[j].col;
-      scm_port_table[j].col = 0;
+      scm_port_table[j].col = 1;
       break;
     default:
       scm_port_table[j].col++;
@@ -716,9 +774,14 @@ void lungetc(c, port)
   int c;
   SCM port;
 {
+  int i = PTOBNUM(port);
 /*	ASSERT(!CRDYP(port), port, ARG2, "too many lungetc");*/
-  scm_port_table[SCM_PORTNUM(port)].unread = c;
-  CAR(port) |= CRDY;
+  if (ptobs[i].ungetc)
+    (ptobs[i].ungetc)(c, port);
+  else {
+    scm_port_table[SCM_PORTNUM(port)].unread = c;
+    CAR(port) |= CRDY;
+  }
 }
 
 SCM scm_read_char(port)
@@ -726,7 +789,7 @@ SCM scm_read_char(port)
 {
   int c;
   if UNBNDP(port) port = cur_inp;
-  else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
+  ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read_char);
   c = lgetc(port);
   if (EOF==c) return EOF_VAL;
   return MAKICHR(c);
@@ -772,26 +835,36 @@ static int flush_ws(port)
 SCM lread(port)
      SCM port;
 {
+  return lread1(port, 0, s_read);
+}
+static SCM lread1(port, nump, what)
+     SCM port;
+     int nump;
+     char *what;
+{
 	int c;
 	SCM tok_buf;
 	if UNBNDP(port) port = cur_inp;
-	else ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, s_read);
+	ASSERT(NIMP(port) && OPINPORTP(port), port, ARG1, what);
 	do {
 	  c = flush_ws(port);
 	  if (EOF==c) return EOF_VAL;
 	  lungetc(c, port);
 	  tok_buf = makstr(30L);
-	} while (EOF_VAL==(tok_buf = lreadr(tok_buf, port)));
+	} while (EOF_VAL==(tok_buf = lreadr(tok_buf, port, nump)));
 	return tok_buf;
 }
 static SCM *loc_readsharp = 0, *loc_readsharpc = 0;
-static SCM lreadpr(tok_buf, port)
+static SCM lreadpr(tok_buf, port, nump)
      SCM tok_buf;
      SCM port;
+     int nump;
 {
 	int c;
 	sizet j;
 	SCM p;
+	if (2==nump)
+	  return lread_rec(tok_buf, port);
 tryagain:
 	c = flush_ws(port);
 	switch (c) {
@@ -800,13 +873,15 @@ tryagain:
 	case '[':
 #endif
 	case '(':
-	  return lreadparen(tok_buf, port, s_list);
+	  return lreadparen(tok_buf, port, nump, s_list);
 #ifdef BRACKETS_AS_PARENS
 	case ']':
 #endif
 	case ')': return UNDEFINED; /* goto tryagain; */
-	case '\'': return cons2(i_quote, lreadr(tok_buf, port), EOL);
-	case '`': return cons2(i_quasiquote, lreadr(tok_buf, port), EOL);
+	case '\'': return cons2(i_quote,
+				lreadr(tok_buf, port, nump), EOL);
+	case '`': return cons2(i_quasiquote,
+			       lreadr(tok_buf, port, nump), EOL);
 	case ',':
 		c = lgetc(port);
 		if ('@'==c) p = i_uq_splicing;
@@ -814,7 +889,7 @@ tryagain:
 			lungetc(c, port);
 			p = i_unquote;
 		}
-		return cons2(p, lreadr(tok_buf, port), EOL);
+		return cons2(p, lreadr(tok_buf, port, nump), EOL);
 	case '#':
 		c = lgetc(port);
 		switch (c) {
@@ -822,7 +897,7 @@ tryagain:
 		case '[':
 #endif
 		case '(':
-			p = lreadparen(tok_buf, port, s_vector);
+			p = lreadparen(tok_buf, port, nump, s_vector);
 			return NULLP(p) ? nullvect : vector(p);
 		case 't': case 'T': return BOOL_T;
 		case 'f': case 'F': return BOOL_F;
@@ -928,18 +1003,42 @@ tok:
 		return CAR(p);
 	}
 }
-static SCM lreadr(tok_buf, port)
+static SCM lreadr(tok_buf, port, nump)
      SCM tok_buf;
      SCM port;
+     int nump;
 {
-  SCM ans = lreadpr(tok_buf, port);
+  SCM ans = lreadpr(tok_buf, port, nump);
   switch (ans) {
   case UNDEFINED:
-    scm_warn("unexpected \")\"", "");
-    return lreadpr(tok_buf, port);
+    scm_warn("unexpected \")\"", "", port);
+    return lreadpr(tok_buf, port, nump);
   }
   return ans;
 }
+static SCM lread_rec(tok_buf, port)
+     SCM tok_buf;
+     SCM port;
+{
+  SCM line, form;
+  int c = flush_ws(port);
+  switch(c) {
+  default:
+    lungetc(c, port);
+    line = scm_port_line(port);
+    form = lreadpr(tok_buf, port, 1);
+    if (NFALSEP(line) && NIMP(form) && 
+	(CONSP(form) || VECTORP(form))) {
+      return cons(SCM_MAKE_LINUM(INUM(line)), form);
+    }
+    return form;
+#ifdef BRACKETS_AS_PARENS
+  case ']':
+#endif
+  case ')': return UNDEFINED;
+  case EOF: return EOF_VAL;
+  }
+}
 
 #ifdef _UNICOS
 _Pragma("noopt");		/* # pragma _CRI noopt */
@@ -977,25 +1076,26 @@ static sizet read_token(ic, tok_buf, port)
 _Pragma("opt");			/* # pragma _CRI opt */
 #endif
 
-static SCM lreadparen(tok_buf, port, name)
+static SCM lreadparen(tok_buf, port, nump, name)
      SCM tok_buf;
      SCM port;
+     int nump;
      char *name;
 {
-  SCM lst, fst, tmp = lreadpr(tok_buf, port);
+  SCM lst, fst, tmp = lreadpr(tok_buf, port, nump ? 2 : 0);
   if (UNDEFINED==tmp) return EOL;
   if (i_dot==tmp) {
-    fst = lreadr(tok_buf, port);
+    fst = lreadr(tok_buf, port, nump ? 1 : 0);
   closeit:
-    tmp = lreadpr(tok_buf, port);
+    tmp = lreadpr(tok_buf, port, 0);
     if (UNDEFINED != tmp) wta(UNDEFINED, "missing close paren", name);
     return fst;
   }
   fst = lst = cons(tmp, EOL);
-  while (UNDEFINED != (tmp = lreadpr(tok_buf, port))) {
+  while (UNDEFINED != (tmp = lreadpr(tok_buf, port, nump ? 2 : 0))) {
     if (EOF_VAL==tmp) wta(lst, s_eofin, s_list);
     if (i_dot==tmp) {
-      CDR(lst) = lreadr(tok_buf, port);
+      CDR(lst) = lreadr(tok_buf, port, nump ? 1 : 0);
       goto closeit;
     }
     lst = (CDR(lst) = cons(tmp, EOL));
@@ -1006,6 +1106,18 @@ static SCM lreadparen(tok_buf, port, name)
 /* These procedures implement synchronization primitives.  Processors
    with an atomic test-and-set instruction can use it here (and not
    DEFER_INTS). */
+char s_swapcar[] = "swap-car!";
+SCM swapcar(pair, value)
+     SCM pair, value;
+{
+  SCM ret;
+  ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_swapcar);
+  DEFER_INTS;
+  ret = CAR(pair);
+  CAR(pair) = value;
+  ALLOW_INTS;
+  return ret;
+}
 char s_tryarb[] = "try-arbiter";
 char s_relarb[] = "release-arbiter";
 long tc16_arbiter;
@@ -1074,16 +1186,17 @@ struct errdesc errmsgs[] = {
 void (* deferred_proc) P((void)) = 0;
 char *errjmp_bad = "init";
 int ints_disabled = 1;
-static int errjmp_recursive = 0;
 unsigned long SIG_deferred = 0;
-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;
 int scm_verbose = 1;		/* Low so that monitor info won't be */
 				/* printed while in init_storage. (BOOM) */
+static int errjmp_recursive = 0;
+static int errobj_codep;
+static SCM err_exp, err_env;
+static char *err_pos, *err_s_subr;
+static cell tmp_errobj = {(SCM)UNDEFINED, (SCM)EOL};
+static cell tmp_loadpath = {(SCM)BOOL_F, (SCM)EOL};
+SCM *loc_errobj = (SCM *)&tmp_errobj;
+SCM *loc_loadpath = (SCM *)&tmp_loadpath;
 long cells_allocated = 0, lcells_allocated = 0,
   mallocated = 0, lmallocated = 0,
   rt = 0, gc_rt, gc_time_taken;
@@ -1113,6 +1226,7 @@ int handle_it(i)
     if NIMP(proc) {	  /* Save environment stack, in case it
 			     moves when applying proc.  Do an ecache gc
 			     to protect contents of stack. */
+      
       SCM estk, *estk_ptr, env, env_tmp;
       DEFER_INTS;
 #ifndef NO_ENV_CACHE
@@ -1142,23 +1256,35 @@ int handle_it(i)
 }
 static char s_eval_string[] = "eval-string";
 static char s_load_string[] = "load-string";
+static SCM i_eval_string = 0;
 SCM scm_eval_string(str)
      SCM str;
 {
+  SCM env = EOL;
+#ifdef SCM_ENV_FILENAME
+  if (i_eval_string)
+    env = scm_env_addprop(SCM_ENV_FILENAME, i_eval_string, env);
+#endif
   str = mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
   str = lread(str);
-  return EVAL(str, (SCM)EOL);
+  return EVAL(str, env, EOL);
 }
+static SCM i_load_string = 0;
 SCM scm_load_string(str)
      SCM str;
 {
+  SCM env = EOL;
+#ifdef SCM_ENV_FILENAME
+  if (i_load_string)
+    env = scm_env_addprop(SCM_ENV_FILENAME, i_load_string, env);
+#endif
   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);
+    SIDEVAL(form, env, EOL);
   }
   return BOOL_T;
 }
@@ -1191,10 +1317,10 @@ SCM scm_top_level(initpath, toplvl_fun)
 	SCM proc = CDR(intern(name, (sizet)strlen(name)));
 	if NIMP(proc) apply(proc, EOL, EOL);
       }}
-    if ((i = errmsgs[i-WNA].parent_err)) goto drloop;
+    i = errmsgs[i-WNA].parent_err;
+    if (i) goto drloop;
   case 1:			/* from everr() */
     def_err_response();
-    dowinds(EOL);
     goto reset_toplvl;
   case 0:
     exitval = MAKINUM(EXIT_SUCCESS);
@@ -1205,6 +1331,7 @@ SCM scm_top_level(initpath, toplvl_fun)
     SIG_deferred = 0;
     deferred_proc = 0;
     ints_disabled = 0;
+    scm_init_INITS();
     if (dumped) {
       lcells_allocated = cells_allocated;
       lmallocated = mallocated;
@@ -1224,13 +1351,13 @@ SCM scm_top_level(initpath, toplvl_fun)
     }
   case -2:			/* abrt */
   reset_toplvl:
-    dowinds(EOL);
     ints_disabled = 1;
     errjmp_bad = (char *)0;
     errjmp_recursive = 0;
     lflush(sys_errp);
     SIG_deferred = 0;
     deferred_proc = 0;
+    gc_hook_active = 0;
     scm_estk_reset(0);
 
     /* Closing the loading file turned out to be a bad idea. */
@@ -1249,12 +1376,12 @@ SCM scm_top_level(initpath, toplvl_fun)
     *loc_loadpath = BOOL_F;
     loadports = EOL;
     ints_disabled = 0;
+    dowinds(EOL);
     ret = toplvl_fun();		/* typically repl() */
     if INUMP(ret) exitval = ret;
     err_pos = (char *)EXIT;
     i = EXIT;
     goto drloop;		/* encountered EOF on stdin */
-    def_err_response();
   case -1:			/* quit */
     dowinds(EOL);
     if (MAKINUM(EXIT_SUCCESS) != exitval) {
@@ -1301,6 +1428,7 @@ SCM scm_port_line(port)
   lnum = scm_port_table[SCM_PORTNUM(port)].line;
   switch (CGETUN(port)) {
   default:
+  case EOF:			/* no ungetted char */
     break;
   case LINE_INCREMENTORS:
     lnum--;
@@ -1312,7 +1440,7 @@ static char s_port_col[] = "port-column";
 SCM scm_port_col(port)
      SCM port;
 {
-  short col;
+  long col;
   ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_col);
   if (! (TRACKED & SCM_PORTFLAGS(port))) return BOOL_F;
   col = scm_port_table[SCM_PORTNUM(port)].col;
@@ -1320,6 +1448,8 @@ SCM scm_port_col(port)
   default:
     col--;
     break;
+  case EOF:			/* no ungetted char */
+    break;
   case LINE_INCREMENTORS:
     col = scm_port_table[SCM_PORTNUM(port)].colprev;
     break;
@@ -1344,15 +1474,13 @@ SCM prog_args()
 }
 
 extern char s_heap[];
-extern sizet hplim_ind;
-extern CELLPTR *hplims;
 void growth_mon(obj, size, units, grewp)
      char *obj;
      long size;
      char *units;
      int grewp;
 {
-  if (verbose>2)
+  if (verbose > 2)
     {
       lputs((grewp ? "; grew " : "; shrank "), sys_errp);
       lputs(obj, sys_errp);
@@ -1360,18 +1488,18 @@ void growth_mon(obj, size, units, grewp)
       intprint(size, -10, sys_errp);
       lputc(' ', sys_errp);
       lputs(units, sys_errp);
-      if ((verbose>4) && (obj==s_heap)) heap_report();
-      lputs("\n", sys_errp);
+      if ((verbose > 4) && (obj==s_heap)) heap_report();
+      lputs("\n; ", sys_errp);
     }
 }
 
 void gc_start(what)
      char *what;
 {
-  if (verbose>3 && FPORTP(cur_errp)) {
+  if (verbose > 4) {
     lputs(";GC(", sys_errp);
     lputs(what, sys_errp);
-    lputs(")", sys_errp);
+    lputs(") ", sys_errp);
   }
   scm_gcs++;
   gc_rt = INUM(my_time());
@@ -1384,10 +1512,9 @@ void gc_end()
 {
   gc_rt = INUM(my_time()) - gc_rt;
   gc_time_taken = gc_time_taken + gc_rt;
-  if (verbose>3) {
-    if (!FPORTP(cur_errp)) lputs(";GC ", sys_errp);
+  if (verbose > 4) {
     intprint(time_in_msec(gc_rt), -10, sys_errp);
-    lputs(" cpu mSec, ", sys_errp);
+    lputs(".ms cpu, ", sys_errp);
     intprint(gc_cells_collected, -10, sys_errp);
     lputs(" cells, ", sys_errp);
     intprint(gc_malloc_collected, -10, sys_errp);
@@ -1410,21 +1537,21 @@ void scm_egc_end()
 }
 void repl_report()
 {
-  if (verbose>1) {
+  if (verbose > 2) {
     lfflush(cur_outp);
     lputs(";Evaluation took ", cur_errp);
     intprint(time_in_msec(INUM(my_time())-rt), -10, cur_errp);
-    lputs(" mSec (", cur_errp);
+    lputs(".ms (", cur_errp);
     intprint(time_in_msec(gc_time_taken), -10, cur_errp);
-    lputs(" in gc) ", cur_errp);
+    lputs(".ms in gc) ", cur_errp);
     intprint(cells_allocated - lcells_allocated, -10, cur_errp);
     lputs(" cells work, ", cur_errp);
     scm_env_work += scm_ecache_len - scm_ecache_index;
     intprint(scm_env_work, -10, cur_errp);
     lputs(" env, ", cur_errp);
     intprint(mallocated - lmallocated, -10, cur_errp);
-    lputs(" bytes other\n", cur_errp);
-    if (verbose>2) {
+    lputs(".B other\n", cur_errp);
+    if (verbose > 3) {
       lputc(';', cur_errp);
       intprint(scm_gcs, -10, cur_errp);
       lputs( " gc, ", cur_errp);
@@ -1449,7 +1576,7 @@ void init_sbrk()
 }
 void scm_brk_report()
 {
-  unsigned long scm_curbrk = sbrk(0),
+  unsigned long scm_curbrk = (unsigned long)sbrk(0),
     dif1 = ((dumped ? scm_dumped_brk : scm_curbrk) - scm_init_brk)/1024,
     dif2 = (scm_curbrk - scm_dumped_brk)/1024;
 
@@ -1464,10 +1591,10 @@ void scm_brk_report()
   lputs("; ", cur_errp);
   intprint(dif1, 10, cur_errp);
   if (dumped) {
-    lputs(dif2<0 ? " - " : " + ", cur_errp);
-    intprint(dif2<0 ? -dif2 : dif2, 10, cur_errp);
+    lputs(dif2 < 0 ? " - " : " + ", cur_errp);
+    intprint(dif2 < 0 ? -dif2 : dif2, 10, cur_errp);
   }
-  lputs(" kb\n", cur_errp);
+  lputs(".kiB\n", cur_errp);
 }
 #endif
 SCM lroom(opt)
@@ -1478,7 +1605,7 @@ SCM lroom(opt)
   intprint(heap_cells, -10, cur_errp);
   lputs(" cells in use, ", cur_errp);
   intprint(mallocated, -10, cur_errp);
-  lputs(" bytes allocated (of ", cur_errp);
+  lputs(".B allocated (of ", cur_errp);
   intprint(mtrigger, 10, cur_errp);
   lputs(")\n", cur_errp);
   if (!UNBNDP(opt)) {
@@ -1486,30 +1613,12 @@ SCM lroom(opt)
     if (scm_init_brk) scm_brk_report();
 #endif
     scm_ecache_report();
-    heap_report();
-    lputc('\n', cur_errp);
+    heap_report(); lputc('\n', cur_errp);
+    gra_report();
     stack_report();
   }
   return UNSPECIFIED;
 }
-void heap_report()
-{
-  sizet i = 0;
-  lputs(";; heap segments:", sys_errp);
-  while(i < hplim_ind) {
-    {
-      long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
-      lputs("\n; 0x", sys_errp);
-      intprint((long)hplims[i++], -16, sys_errp);
-      lputs(" - 0x", sys_errp);
-      intprint((long)hplims[i++], -16, sys_errp);
-      lputs("; ", sys_errp);
-      intprint(seg_cells, 10, sys_errp);
-      lputs(" cells; ", sys_errp);
-      intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
-      lputs(" kb", sys_errp);
-    }}
-}
 void scm_ecache_report()
 {
   intprint(scm_estk_size, 10 , cur_errp);
@@ -1521,12 +1630,12 @@ void scm_ecache_report()
 }
 void exit_report()
 {
-  if (verbose>2) {
+  if (verbose > 2) {
     lputs(";Totals: ", cur_errp);
     intprint(time_in_msec(INUM(my_time())), -10, cur_errp);
-    lputs(" mSec my time, ", cur_errp);
+    lputs(".ms my time, ", cur_errp);
     intprint(time_in_msec(INUM(your_time())), -10, cur_errp);
-    lputs(" mSec your time\n", cur_errp);
+    lputs(".ms your time\n", cur_errp);
   }
 }
 
@@ -1541,11 +1650,13 @@ SCM prolixity(arg)
   return MAKINUM(old);
 }
 
+static SCM i_repl;
 SCM repl()
 {
   SCM x;
+  SCM env = EOL; /* scm_env_addprop(SCM_ENV_FILENAME, i_repl, EOL); */
   int c;
-  if OPINPORTP(cur_inp) {
+  if (OPINPORTP(cur_inp) && OPOUTPORTP(cur_outp)) {
     repl_report();
     while(1) {
       if OPOUTPORTP(cur_inp) {	/* This case for curses window */
@@ -1579,10 +1690,27 @@ SCM repl()
 	  {lfflush(cur_outp); newline(cur_inp);}
 	else newline(cur_outp);
 #endif
-      x = EVAL(x, (SCM)EOL);
+      if (NIMP(x)) {
+	x = CONSP(x) ?
+	  scm_eval_values(x, env, (SCM)EOL) :
+	  cons(EVAL(x, env, (SCM)EOL), EOL);
+      }
+      else
+	x = cons(x, EOL);
       repl_report();
-      iprin1(x, cur_outp, 1);
-      lputc('\n', cur_outp);
+      if (IMP(x))
+	{if (verbose > 2) lputs(";;no values\n", cur_outp);}
+      else if (IMP(CDR(x))) {
+	iprin1(CAR(x), cur_outp, 1);
+	lputc('\n', cur_outp);
+      }
+      else
+	while (NIMP(x)) {
+	  lputc(' ', cur_outp);
+	  iprin1(CAR(x), cur_outp, 1);
+	  lputc('\n', cur_outp);
+	  x = CDR(x);
+	}
     }
   }
   return UNSPECIFIED;
@@ -1623,10 +1751,10 @@ SCM scm_unexec(newpath)
 #ifdef CAREFUL_INTS
 ints_infot *ints_info = 0;
 static void ints_viol_iprin(num)
-     long num;
+     int num;
 {
   char num_buf[INTBUFLEN];
-  sizet i = iint2str(num, 10, num_buf);
+  sizet i = iint2str(num+0L, 10, num_buf);
   num_buf[i] = 0;
   fputs(num_buf, stderr);
 }
@@ -1640,7 +1768,7 @@ void ints_viol(info, sense)
   fputs(": ints already ", stderr);
   fputs(sense ? "dis" : "en", stderr);
   fputs("abled (", stderr);
-  ints_viol_iprin((long)ints_disabled);
+  ints_viol_iprin(ints_disabled);
   fputs(")\n", stderr);
   if (ints_info) {
     fputs(ints_info->fname, stderr);
@@ -1657,7 +1785,7 @@ void ints_warn(str1, str2, fname, linum)
   fputs(fname, stderr);
   fputc(':', stderr);
   ints_viol_iprin(linum);
-  fputs(" :uprotected call to ", stderr);
+  fputs(": unprotected call to ", stderr);
   fputs(str1, stderr);
   if (str2) {
     fputs(" (", stderr);
@@ -1668,22 +1796,43 @@ void ints_warn(str1, str2, fname, linum)
 }
 #endif
 
-SCM tryload(filename)
-     SCM filename;
+#ifdef CAUTIOUS
+static SCM f_read_numbered;
+static char s_read_numbered[] = "read-numbered";
+SCM scm_read_numbered(port)
+     SCM port;
+{
+  return lread1(port, 2, s_read_numbered);
+}
+#endif
+
+SCM tryload(filename, reader)
+     SCM filename, reader;
 {
   ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_load);
+  if (FALSEP(reader)) reader = UNDEFINED;
+#ifndef RECKLESS
+  if (!UNBNDP(reader)) scm_arity_check(reader, 1L, s_load);
+#endif
   {
     SCM oloadpath = *loc_loadpath;
     SCM oloadports = loadports;
     SCM form, port;
+    SCM env = EOL;
     port = open_file(filename, makfromstr("r?", (sizet)2*sizeof(char)));
     if FALSEP(port) return port;
     *loc_loadpath = filename;
     loadports = cons(port, loadports);
+#ifdef SCM_ENV_FILENAME
+    env = scm_env_addprop(SCM_ENV_FILENAME, filename, env);
+#endif
     while(1) {
-      form = lread(port);
+      if (UNBNDP(reader))
+	form = lread(port);
+      else
+	form = scm_cvapply(reader, 1L, &port);
       if (EOF_VAL==form) break;
-      SIDEVAL(form, EOL);
+      SIDEVAL(form, env, EOL);
     }
     close_port(port);
     loadports = oloadports;
@@ -1692,68 +1841,34 @@ SCM tryload(filename)
   return BOOL_T;
 }
 
-#ifdef CAUTIOUS
-static long num_frames(estk, i)
-     SCM estk;
-     int i;
+void scm_line_msg(file, linum, port)
+    SCM file, linum, port;
 {
-  long n = 0;
-  while NIMP(estk) {
-    n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
-    i = INUM(SCM_ESTK_PARENT_INDEX(estk));
-    estk = SCM_ESTK_PARENT(estk);
+  iprin1(file, port, 1);
+  if (SCM_LINUMP(linum)) {
+    lputs(", line ", port);
+    intprint(SCM_LINUM(linum), -10, port);
   }
-  return n;
-}
-
-extern SCM scm_trace;
-SCM scm_stack_trace()
-{
-  SCM ste, lste, estk = scm_estk;
-  int i = (scm_estk_ptr - VELTS(scm_estk));
-  int n, nf = num_frames(estk, i);
-  int ellip = 0, nbrk1 = 7, nbrk2 = nf - 5;
-  if (nf <= 0) return BOOL_F;
-  nf = 0;
-  lputs("\n;STACK TRACE", cur_errp);
-  if (NIMP(scm_trace) && (scm_trace != scm_estk_ptr[2]))
-    if (reset_safeport(sys_safep, 65, cur_errp)) {
-      /* The usual C setjmp, not SCM's setjump. */
-      if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
-	    lputs("\n+; ", sys_safep);
-	    iprin1(scm_trace, sys_safep, 1);
-      }
-    }
-  lste = UNDEFINED;
-  while NIMP(estk) {
-    n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
-    for (; n > 0; n--) {
-      if (nf <= nbrk1 || nf >= nbrk2) {
-	ste = VELTS(estk)[SCM_ESTK_BASE + n*SCM_ESTK_FRLEN + 2];
-	if (ste != lste) {
-	  lste = ste;
-	  if (reset_safeport(sys_safep, 65, cur_errp)) {
-	    /* The usual C setjmp, not SCM's setjump. */
-	    if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
-	      lputc('\n', cur_errp);
-	      intprint(nf, -10, sys_safep);
-	      lputs("; ", sys_safep);
-	      iprin1(ste, sys_safep, 1);
-	    }
-	  }
-	  else if (! ellip++)
-	    lputs("\n...", cur_errp);
-	}
-      }
-      nf++;
+  lputs(": ", port);
+}
+void scm_err_line(what, file, linum, port)
+     char *what;
+     SCM file, linum, port;
+{
+  lputs(what, port);
+  if (NIMP(file) && STRINGP(file))
+    scm_line_msg(file, linum, port);
+#ifdef CAUTIOUS
+  else {
+    SCM env = scm_env_getprop(SCM_ENV_FILENAME, scm_trace_env);
+    if (NIMP(env)) {
+      file = CAR(env);
+      scm_check_linum(scm_trace, &linum);
+      scm_line_msg(file, linum, port);
     }
-    i = INUM(SCM_ESTK_PARENT_INDEX(estk));
-    estk = SCM_ESTK_PARENT(estk);
   }
-  lputc('\n', cur_errp);
-  return BOOL_T;
-}
 #endif
+}
 
 static void err_head(str)
      char *str;
@@ -1761,11 +1876,10 @@ static void err_head(str)
   SCM lps;
   int oerrno = errno;
   exitval = MAKINUM(EXIT_FAILURE);
-  if NIMP(cur_outp) lfflush(cur_outp);
-  lputc('\n', cur_errp);
+  if (NIMP(cur_outp) && OPOUTPORTP(cur_outp)) lfflush(cur_outp);
   for (lps = loadports; NIMP(lps); lps = CDR(lps)) {
-    if (lps != loadports)
-      lputs("\n  ;loaded from ", cur_errp);
+    lputs(lps==loadports ? "\n;While loading " : "\n  ;loaded from ",
+	  cur_errp);
     iprin1(scm_port_filename(CAR(lps)), cur_errp, 1);
     lputs(", line ", cur_errp);
     iprin1(scm_port_line(CAR(lps)), cur_errp, 1);
@@ -1779,17 +1893,22 @@ static void err_head(str)
   if (errno>0) perror(str);
   fflush(stderr);
 }
-void scm_warn(str1, str2)
+void scm_warn(str1, str2, obj)
      char *str1, *str2;
+     SCM obj;
 {
   err_head("WARNING");
-  lputs("WARNING: ", cur_errp);
+  scm_err_line("WARNING: ", UNDEFINED, UNDEFINED, cur_errp);
   lputs(str1, cur_errp);
-  if (str2) {
+  if (str2 && *str2) {
     lputs(str2, cur_errp);
     lputc('\n', cur_errp);
-    lfflush(cur_errp);
   }
+  if (!UNBNDP(obj)) {
+    iprin1(obj, cur_errp, 1);
+    lputc('\n', cur_errp);
+  }
+  lfflush(cur_errp);
 }
 
 SCM lerrno(arg)
@@ -1812,25 +1931,41 @@ SCM lperror(arg)
 }
 static void def_err_response()
 {
-  SCM env = err_env, obj = *loc_errobj;
+  SCM file, env = err_env, obj = *loc_errobj;
+  SCM linum = UNDEFINED;
+  int badport = IMP(cur_errp) || !OPOUTPORTP(cur_errp);
+  int writing = 2; /* Value of 2 used only for printing error messages */
+  int codep = errobj_codep;
   DEFER_INTS;
-  if (errjmp_recursive++) {
+  if (badport || (errjmp_recursive++)) {
+    if (IMP(def_errp) || !OPOUTPORTP(def_errp)) exit(EXIT_FAILURE);
     lputs("RECURSIVE ERROR: ", def_errp);
-    if (TYP16(cur_errp)==tc16_sfport) {
+    if (badport || TYP16(cur_errp)==tc16_sfport) {
+      lputs("reverting from ", def_errp);
+      iprin1(cur_errp, def_errp, 2);
+      lputs("to default error port\n", def_errp);
       cur_errp = def_errp;
       errjmp_recursive = 0;
-      lputs("reverting to default error port\n", def_errp);
     }
     else exit(EXIT_FAILURE);
   }
+#ifdef SCM_ENV_FILENAME
+  file = scm_env_getprop(SCM_ENV_FILENAME, env);
+  if (NIMP(file)) file = CAR(file);
+  else file = UNDEFINED;
+#else
+  file = BOOL_F;
+#endif
+  if (codep) obj = scm_check_linum(obj, &linum);
+  err_exp = scm_check_linum(err_exp, UNBNDP(linum) ? &linum : 0L);
   err_head("ERROR");
+  scm_err_line("ERROR: ", file, linum, cur_errp);
   if (err_s_subr && *err_s_subr) {
-    lputs("ERROR: ", cur_errp);
     lputs(err_s_subr, cur_errp);
     lputs(": ", cur_errp);
   }
   if (!err_pos) return;		/* Already been printed */
-  if (err_pos==(char *)ARG1 && UNBNDP(*loc_errobj)) err_pos = (char *)WNA;
+  if (err_pos==(char *)ARG1 && UNBNDP(obj)) err_pos = (char *)WNA;
 #ifdef nosve
   if ((~0x1fL) & (short)err_pos) lputs(err_pos, cur_errp);
   else if (WNA > (short)err_pos) {
@@ -1850,40 +1985,26 @@ static void def_err_response()
   if (!UNBNDP(obj))
     if (reset_safeport(sys_safep, 55, cur_errp))
       if (0==setjmp(SAFEP_JMPBUF(sys_safep)))
-	iprin1(obj, sys_safep, 1);
+	if (codep) scm_princode(obj, EOL, sys_safep, writing);
+	else iprin1(obj, sys_safep, writing);
   if UNBNDP(err_exp) goto getout;
   if NIMP(err_exp) {
     if (reset_safeport(sys_safep, 55, cur_errp))
       if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
 	lputs("\n; in expression: ", cur_errp);
-	if NCONSP(err_exp)
-	  iprin1(err_exp, sys_safep, 1);
+	if (NCONSP(err_exp)) scm_princode(err_exp, env, sys_safep, writing);
 	else if (UNDEFINED==CDR(err_exp))
-	  iprin1(CAR(err_exp), sys_safep, 1);
-	else iprlist("(... ", err_exp, ')', sys_safep, 1);
+	  iprin1(CAR(err_exp), sys_safep, writing);
+	else {
+	  if (UNBNDP(env)) iprlist("(... ", err_exp, ')', sys_safep, writing);
+	  else scm_princode(err_exp, env, sys_safep, writing);
+	}
       }
   }
-  if (NIMP(env) && ENVP(env)) {
-    if (scm_env==env) {
-      lputs("\n; in expand-time environment: ", cur_errp);
-      iprin1(env, cur_errp, 1);
-    }
-    env = CDR(env);
-  }
-  if (NULLP(env))
-    lputs("\n; in top level environment.", cur_errp);
-  else {
-    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);
-    }
-  }
+  scm_scope_trace(env);
  getout:
 #ifdef CAUTIOUS
-  scm_stack_trace();
+  scm_stack_trace(UNDEFINED);
 #endif
   lputc('\n', cur_errp);
   lfflush(cur_errp);
@@ -1902,15 +2023,17 @@ static void def_err_response()
   errno = 0;
   ALLOW_INTS;
 }
-void everr(exp, env, arg, pos, s_subr)
+void everr(exp, env, arg, pos, s_subr, codep)
      SCM exp, env, arg;
      char *pos, *s_subr;
+     int codep;
 {
   err_exp = exp;
   err_env = env;
   *loc_errobj = arg;
   err_pos = pos;
   err_s_subr = s_subr;
+  errobj_codep = codep;
   if (errjmp_bad || errjmp_recursive) def_err_response();
   longjump(CONT(rootcont)->jmpbuf,
 	   (~0x1fL) & (long)pos || (WNA > (long)pos) ?
@@ -1919,9 +2042,23 @@ void everr(exp, env, arg, pos, s_subr)
 }
 void wta(arg, pos, s_subr)
      SCM arg;
-char *pos, *s_subr;
+     char *pos, *s_subr;
 {
- everr(UNDEFINED, EOL, arg, pos, s_subr);
+#ifndef RECKLESS
+  everr(scm_trace, scm_trace_env, arg, pos, s_subr, 0);
+#else
+  everr(UNDEFINED, EOL, arg, pos, s_subr, 0);
+#endif
+}
+void scm_experr(arg, pos, s_subr)
+     SCM arg;
+     char *pos, *s_subr;
+{
+#ifndef RECKLESS
+  everr(scm_trace, scm_trace_env, arg, pos, s_subr, !0);
+#else
+  everr(UNDEFINED, EOL, arg, pos, s_subr, !0);
+#endif
 }
 SCM cur_input_port()
 {
@@ -1988,16 +2125,12 @@ static iproc subr0s[] = {
 	{"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},
-	{s_tryload, tryload},
 	{s_load_string, scm_load_string},
 	{s_eval_string, scm_eval_string},
 	{s_perror, lperror},
@@ -2028,6 +2161,7 @@ static iproc subr2os[] = {
 	{s_write, lwrite},
 	{s_display, display},
 	{s_write_char, write_char},
+	{s_tryload, tryload},
 #ifdef CAN_DUMP
 	{s_unexec, scm_unexec},
 #endif
@@ -2040,17 +2174,26 @@ void init_repl( iverbose )
      int iverbose;
 {
 	sysintern(s_ccl, MAKINUM(CHAR_CODE_LIMIT));
+	i_repl = CAR(sysintern("repl", UNDEFINED));
 	loc_errobj = &CDR(sysintern("errobj", UNDEFINED));
 	loc_loadpath = &CDR(sysintern("*load-pathname*", BOOL_F));
 	loc_readsharp = &CDR(sysintern("read:sharp", UNDEFINED));
 	loc_readsharpc = &CDR(sysintern("read:sharp-char", UNDEFINED));
+	loc_broken_pipe = &CDR(sysintern("broken-pipe", UNDEFINED));
 	scm_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);
+#ifdef CAUTIOUS
+	f_read_numbered =
+	  make_subr(s_read_numbered, tc7_subr_1, scm_read_numbered);
+#endif
 	add_feature(s_char_readyp);
+	make_subr(s_swapcar, tc7_subr_2, swapcar);
 	make_subr(s_wfi, tc7_lsubr, wait_for_input);
+	i_eval_string = CAR(sysintern(s_eval_string, UNDEFINED));
+	i_load_string = CAR(sysintern(s_load_string, UNDEFINED));
 #ifdef CAN_DUMP
 	add_feature("dump");
 	scm_ldstr("\
diff --git a/requires.scm b/requires.scm
index bd4b8bf..97d7cdd 100644
--- a/requires.scm
+++ b/requires.scm
@@ -2,12 +2,12 @@
 
 (set! library-vicinity
   (let* ((vl (case (software-type)
-	       ((AMIGA)	'(#\: #\/))
-	       ((MS-DOS WINDOWS ATARIST OS/2)	'(#\\ #\/))
-	       ((MACOS THINKC)	'(#\:))
-	       ((NOSVE)	'(#\: #\.))
-	       ((UNIX COHERENT)	'(#\/))
-	       ((VMS)	'(#\: #\]))))
+	       ((AMIGA) '(#\: #\/))
+	       ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/))
+	       ((MACOS THINKC) '(#\:))
+	       ((NOSVE) '(#\: #\.))
+	       ((UNIX COHERENT PLAN9) '(#\/))
+	       ((VMS) '(#\: #\]))))
 	 (iv (implementation-vicinity))
 	 (vc (and (positive? (string-length iv))
 		  (string-ref iv (+ -1 (string-length iv)))))
diff --git a/rgx.c b/rgx.c
index e89564a..0c1c377 100644
--- a/rgx.c
+++ b/rgx.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -55,7 +55,7 @@
 #endif
 
 static char rcsid[] =
-   "$Id: rgx.c,v 1.12 1999/09/07 16:55:54 jaffer Exp $";
+   "$Id: rgx.c,v 1.15 2002/04/13 20:41:02 jaffer Exp $";
 
 #ifdef HAVE_ALLOCA
 # include <alloca.h>
@@ -121,13 +121,13 @@ typedef struct regex_info {
 sizet fregex(ptr)
      CELLPTR ptr;
 {
-  regfree(RGX(ptr));
+  regfree(RGX((SCM)ptr));
 #ifndef _GNU_SOURCE
   /* options are null => we compiled the anchored pattern */
-  if (RGX_INFO(ptr)->options==0)
-    regfree(RGX2(ptr));
+  if (RGX_INFO((SCM)ptr)->options==0)
+    regfree(RGX2((SCM)ptr));
 #endif
-  must_free(CHARS(ptr), (sizet)LENGTH(ptr));
+  must_free(CHARS((SCM)ptr), (sizet)LENGTH((SCM)ptr));
   return 0;
 }
 
diff --git a/rope.c b/rope.c
index 671279a..af62c41 100644
--- a/rope.c
+++ b/rope.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -85,7 +85,7 @@ unsigned char num2uchar(num, pos, s_caller)
      char *pos, *s_caller;
 {
   unsigned long res = INUM(num);
-  ASSERT(INUMP(num) && (255L >= res),num,pos,s_caller);
+  ASSERT(INUMP(num) && (255L >= res), num, pos, s_caller);
   return (unsigned char) res;
 }
 unsigned short num2ushort(num, pos, s_caller)
@@ -93,7 +93,7 @@ unsigned short num2ushort(num, pos, s_caller)
      char *pos, *s_caller;
 {
   unsigned long res = INUM(num);
-  ASSERT(INUMP(num) && (65535L >= res),num,pos,s_caller);
+  ASSERT(INUMP(num) && (65535L >= res), num, pos, s_caller);
   return (unsigned short) res;
 }
 unsigned long num2ulong(num, pos, s_caller)
@@ -251,7 +251,7 @@ SCM scm_evstr(str)
 {
   SCM lsym;
   NEWCELL(lsym);
-  SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
+  SETLENGTH(lsym, strlen(str), tc7_ssymbol);
   SETCHARS(lsym, str);
   return scm_eval_string(lsym);
 }
@@ -260,7 +260,7 @@ void scm_ldstr(str)
 {
   SCM lsym;
   NEWCELL(lsym);
-  SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
+  SETLENGTH(lsym, strlen(str), tc7_ssymbol);
   SETCHARS(lsym, str);
   scm_load_string(lsym);
 }
@@ -269,7 +269,7 @@ int scm_ldfile(path)
 {
   SCM name = makfrom0str(path);
   *loc_errobj = name;
-  return BOOL_F==tryload(name);
+  return BOOL_F==tryload(name, UNDEFINED);
 }
 int scm_ldprog(path)
      char *path;
@@ -381,15 +381,14 @@ unsigned long scm_base_addr(v, s_name)
 }
 #endif /* ARRAYS */
 
+extern sizet hplim_ind;
+extern CELLPTR *hplims;
+
 /* scm_cell_p() returns !0 if the SCM argument `x' is cell-aligned and
    points into a valid heap segment.  This code is duplicated from
    mark_locations() and obunhash() in "sys.c", which means that
    changes to these routines must be coordinated. */
 
-#include "continue.h"
-extern sizet hplim_ind;
-extern CELLPTR *hplims;
-
 int scm_cell_p(x)
      SCM x;
 {
@@ -413,6 +412,21 @@ int scm_cell_p(x)
 	return 0;
 }
 
+long scm_protidx = 0;
+
+SCM scm_gc_protect(obj)
+     SCM obj;
+{
+  long len;
+  ASSERT(NIMP(scm_uprotects), MAKINUM(20), NALLOC, "protects");
+  if IMP(obj) return obj;
+  len = LENGTH(scm_uprotects);
+  if (scm_protidx >= len) resizuve(scm_uprotects, MAKINUM(len + (len>>2)));
+  VELTS(scm_uprotects)[scm_protidx++] = obj;
+  return obj;
+}
+
 void init_rope()
 {
+  scm_uprotects = make_vector(MAKINUM(20), UNDEFINED);
 }
diff --git a/sc2.c b/sc2.c
index 9dd64b9..3df2f1a 100644
--- a/sc2.c
+++ b/sc2.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
diff --git a/scl.c b/scl.c
index 51d9eab..57d020e 100644
--- a/scl.c
+++ b/scl.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -45,11 +45,19 @@
 #include "scm.h"
 
 #ifdef FLOATS
-# include <math.h>
+# ifndef PLAN9
+#  include <math.h>
+# endif
 
 static double big2scaldbl P((SCM b, int expt));
 static SCM bigdblop P((int op, SCM b, double re, double im));
 static SCM inex_divbigbig P((SCM a, SCM b));
+static int apx_log10 P((double x));
+static double lpow10 P((double x, int n));
+static sizet idbl2str P((double f, char *a));
+static sizet iflo2str P((SCM flt, char *str));
+static void add1 P((double f, double *fsum));
+static long scm_twos_power P((SCM n));
 
 static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar",
 	    s_magnitude[] = "magnitude", s_angle[] = "angle",
@@ -83,7 +91,13 @@ static char s_intexpt[] = "integer-expt";
 
 /*** NUMBERS -> STRINGS ***/
 #ifdef FLOATS
-static int dbl_mant_dig;
+# ifndef DBL_MANT_DIG
+#  define DBL_MANT_DIG dbl_mant_dig
+# endif
+static int dbl_mant_dig = 0;
+static double max_dbl_int;       /* Integers less than or equal to max_dbl_int
+				    are representable exactly as doubles. */
+static double dbl_eps;
 double dbl_prec(x)
      double x;
 {
@@ -91,10 +105,10 @@ double dbl_prec(x)
   double frac = frexp(x, &expt);
 # ifdef DBL_MIN_EXP
   if (0.0==x || expt < DBL_MIN_EXP) /* gradual underflow */
-    return ldexp(1.0, -dbl_mant_dig) * ldexp(1.0, DBL_MIN_EXP);
+    return ldexp(1.0, -DBL_MANT_DIG) * ldexp(1.0, DBL_MIN_EXP);
 # endif
-  if (1.0==frac) return ldexp(1.0, expt - dbl_mant_dig + 1);
-  return ldexp(1.0, expt - dbl_mant_dig);
+  if (1.0==frac) return ldexp(1.0, expt - DBL_MANT_DIG + 1);
+  return ldexp(1.0, expt - DBL_MANT_DIG);
 }
 
 static double llog2 = 0.3010299956639812; /* log10(2) */
@@ -130,7 +144,7 @@ static double lpow10(x, n)
 
 /* DBL2STR_FUZZ is a somewhat arbitrary guard against
    round off error in scaling f and fprec. */
-#define DBL2STR_FUZZ 0.9
+# define DBL2STR_FUZZ 0.9
 int dblprec;
 static sizet idbl2str(f, a)
      double f;
@@ -479,14 +493,23 @@ SCM istr2int(str, len, radix)
       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;
+      if (n > ln
+# ifdef hpux
+	  || (-n > -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */
+# endif
+	  ) goto ovfl;
       break;
     default:
       return BOOL_F;		/* not a digit */
     }
   } while (i < len);
-  if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl;
+  if (lead_neg) {
+    if (n < MOST_NEGATIVE_FIXNUM) goto ovfl;
+  }
+  else {
+    if (n < -MOST_POSITIVE_FIXNUM) goto ovfl;
+    n = -n;
+  }
   return MAKINUM(n);
  ovfl:				/* overflow scheme integer */
   return BOOL_F;
@@ -494,6 +517,34 @@ SCM istr2int(str, len, radix)
 #endif
 
 #ifdef FLOATS
+# ifdef BIGDIG
+static char twostab[] = {4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0};
+static long scm_twos_power(n)
+     SCM n;
+{
+  long d, c = 0;
+  int d4;
+#  ifdef BIGDIG
+  if NINUMP(n) {
+    BIGDIG *ds;
+    int i = 0;
+    ds = BDIGITS(n);
+    while (0==(d = ds[i++])) c += BITSPERDIG;
+    goto out;
+  }
+#  endif
+  d = INUM(n);
+  if (0==d) return 0;
+ out:
+  do {
+    d4 = 15 & d;
+    c += twostab[d4];
+    d >>= 4;
+  } while (0==d4);
+  return c;
+}
+# endif /* def BIGDIG */
+
 SCM istr2flo(str, len, radix)
      register char *str;
      register long len;
@@ -965,6 +1016,29 @@ SCM numberp(x)
   return BOOL_F;
 }
 #ifdef FLOATS
+# ifdef BIGDIG
+int scm_bigdblcomp(b, d)
+     SCM b;
+     double d;
+{
+  sizet dlen, blen;
+  int dneg = d < 0 ? 1 : 0;
+  int bneg = BIGSIGN(b) ? 1 : 0;
+  if (bneg < dneg) return -1;
+  if (bneg > dneg) return 1;
+  frexp(d, &dlen);
+  blen = INUM(scm_intlength(b));
+  if (blen > dlen) return dneg ? 1 : -1;
+  if (blen < dlen) return dneg ? -1 : 1;
+  if ((blen <= DBL_MANT_DIG) || (blen - scm_twos_power(b)) <= DBL_MANT_DIG) {
+    double bd = big2dbl(b);
+    if (bd > d) return -1;
+    if (bd < d) return 1;
+    return 0;
+  }
+  return bigcomp(b, dbl2big(d));
+}
+# endif
 SCM realp(x)
      SCM x;
 {
@@ -1018,7 +1092,8 @@ SCM eqp(x, y)
       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;
+      return (REALP(y) && (0==scm_bigdblcomp(x, REALPART(y)))) ?
+	BOOL_T : BOOL_F;
     }
     ASRTGO(INEXP(x), badx);
 # else
@@ -1091,7 +1166,7 @@ SCM lessp(x, y)
       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;
+      return (1==scm_bigdblcomp(x, REALPART(y))) ? BOOL_T : BOOL_F;
     }
     ASRTGO(REALP(x), badx);
 # else
@@ -1100,7 +1175,7 @@ SCM lessp(x, y)
     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;
+    if BIGP(y) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F;
     ASRTGO(REALP(y), bady);
 # else
     ASRTGO(NIMP(y) && REALP(y), bady);
@@ -1248,10 +1323,12 @@ SCM negativep(x)
   return (x < INUM0) ? BOOL_T : BOOL_F;
 }
 
+static char s_exactprob[] = "not representable as inexact";
 SCM lmax(x, y)
      SCM x, y;
 {
 #ifdef FLOATS
+  SCM t;
   double z;
 #endif
   if UNBNDP(y) {
@@ -1270,8 +1347,11 @@ SCM lmax(x, y)
       ASRTGO(NIMP(y), bady);
       if BIGP(y) return (1==bigcomp(x, y)) ? y : x;
       ASRTGO(REALP(y), bady);
+    big_dbl:
+      if (-1 != scm_bigdblcomp(x, REALPART(y))) return y;
       z = big2dbl(x);
-      return (z < REALPART(y)) ? y : makdbl(z, 0.0);
+      ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
+      return makdbl(z, 0.0);
     }
     ASRTGO(REALP(x), badx);
 # else
@@ -1280,7 +1360,9 @@ SCM lmax(x, y)
     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;
+    if BIGP(y) {
+      t = y; y = x; x = t; goto big_dbl;
+    }
     ASRTGO(REALP(y), bady);
 # else
     ASRTGO(NIMP(y) && REALP(y), bady);
@@ -1330,6 +1412,7 @@ SCM lmin(x, y)
      SCM x, y;
 {
 #ifdef FLOATS
+  SCM t;
   double z;
 #endif
   if UNBNDP(y) {
@@ -1348,8 +1431,11 @@ SCM lmin(x, y)
       ASRTGO(NIMP(y), bady);
       if BIGP(y) return (-1==bigcomp(x, y)) ? y : x;
       ASRTGO(REALP(y), bady);
+    big_dbl:
+      if (1 != scm_bigdblcomp(x, REALPART(y))) return y;
       z = big2dbl(x);
-      return (z > REALPART(y)) ? y : makdbl(z, 0.0);
+      ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
+      return makdbl(z, 0.0);
     }
     ASRTGO(REALP(x), badx);
 # else
@@ -1358,7 +1444,9 @@ SCM lmin(x, y)
     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;
+    if BIGP(y) {
+      t = y; y = x; x = t; goto big_dbl;
+    }
     ASRTGO(REALP(y), bady);
 # else
     ASRTGO(NIMP(y) && REALP(y), bady);
@@ -1960,6 +2048,10 @@ SCM scm_intexpt(z1, z2)
      SCM z1, z2;
 {
   SCM acc = MAKINUM(1L);
+  int recip = 0;
+#ifdef FLOATS
+  double dacc, dz1;
+#endif
 #ifdef BIGDIG
   if (INUM0==z1 || acc==z1) return z1;
   else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
@@ -1968,18 +2060,17 @@ SCM scm_intexpt(z1, z2)
   z2 = INUM(z2);
   if (z2 < 0) {
     z2 = -z2;
-    z1 = divide(z1, UNDEFINED);
+    recip = 1; /*    z1 = divide(z1, UNDEFINED); */
   }
   if INUMP(z1) {
     long tmp, iacc = 1, iz1 = INUM(z1);
+#ifdef FLOATS
+    if (recip) { dz1 = iz1; goto flocase; }
+#endif
     while (1) {
       if (0==z2) {
 	acc = long2num(iacc);
-#ifndef RECKLESS
-	if (FALSEP(z1))
-	  errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt);
-#endif
-	return acc;
+	break;
       }
       if (1==z2) {
 	tmp = iacc*iz1;
@@ -1991,8 +2082,7 @@ SCM scm_intexpt(z1, z2)
 	  goto gencase;
 	}
 	acc = long2num(tmp);
-	ASRTGO(NFALSEP(acc), errout);
-	return acc;
+	break;
       }
       if (z2 & 1) {
 	tmp = iacc*iz1;
@@ -2005,28 +2095,37 @@ SCM scm_intexpt(z1, z2)
       iz1 = tmp;
       z2 >>= 1;
     }
+#ifndef RECKLESS
+    if (FALSEP(acc))
+      errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt);
+#endif
+    goto ret;
   }
   ASSERT(NIMP(z1), z1, ARG1, s_intexpt);
-#ifdef FLOATS			/* Move to scl.c ? */
+#ifdef FLOATS
   if REALP(z1) {
-    double dacc = 1.0, dz1 = REALPART(z1);
+    dz1 = REALPART(z1);
+  flocase:
+    dacc = 1.0;
     while(1) {
-      if (0==z2) return makdbl(dacc, 0.0);
-      if (1==z2) return makdbl(dacc*dz1, 0.0);
+      if (0==z2) break;
+      if (1==z2) {dacc = dacc*dz1; break;}
       if (z2 & 1) dacc = dacc*dz1;
       dz1 = dz1*dz1;
       z2 >>= 1;
     }
+    return makdbl(recip ? 1.0/dacc : dacc, 0.0);
   }
 #endif
  gencase:
   while(1) {
-    if (0==z2) return acc;
-    if (1==z2) return product(acc, z1);
+    if (0==z2) break;
+    if (1==z2) {acc = product(acc, z1); break;}
     if (z2 & 1) acc = product(acc, z1);
     z1 = product(z1, z1);
     z2 >>= 1;
   }
+ ret: return recip ? divide(acc, UNDEFINED) : acc;
 }
 
 #ifdef FLOATS
@@ -2242,8 +2341,11 @@ SCM in2ex(z)
 # 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 */
+    if ((u <= MOST_POSITIVE_FIXNUM)
+#  ifdef hpux
+	&& (-u <= -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */
+#  endif
+	) {
       SCM ans = MAKINUM((long)u);
       if (INUM(ans)==(long)u) return ans;
     }
@@ -2349,6 +2451,8 @@ static SCM bigdblop(op, b, re, im)
   }
   case '\\':
     return makdbl(ldexp(re/bm, -i), 0.0==im ? 0.0 : ldexp(im/bm, -i));
+  default:
+    return UNSPECIFIED;
   }
 }
 static SCM inex_divbigbig(a, b)
@@ -2371,6 +2475,64 @@ static SCM inex_divbigbig(a, b)
   }
   return makdbl(r, 0.0);
 }
+
+static char s_dfloat_parts[] = "double-float-parts";
+SCM scm_dfloat_parts(f)
+     SCM f;
+{
+  int expt, ndig = DBL_MANT_DIG;
+  double mant = frexp(num2dbl(f, (char *)ARG1, s_dfloat_parts), &expt);
+#  ifdef DBL_MIN_EXP
+  if (expt < DBL_MIN_EXP)
+    ndig -= DBL_MIN_EXP - expt;
+#  endif
+  mant *= ldexp(1.0, ndig);
+  expt -= ndig;
+  return scm_values(dbl2big(mant), MAKINUM(expt), EOL, s_dfloat_parts);
+}
+static char s_make_dfloat[] = "make-double-float";
+SCM scm_make_dfloat(mant, expt)
+     SCM mant, expt;
+{
+  double dmant = num2dbl(mant, (char *)ARG1, s_make_dfloat);
+  int e = INUM(expt);
+  ASSERT(INUMP(expt), expt, ARG2, s_make_dfloat);
+  ASSERT((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
+	 OUTOFRANGE, s_make_dfloat);
+  return makdbl(ldexp(dmant, e), 0.0);
+}
+static char s_next_dfloat[] = "next-double-float";
+SCM scm_next_dfloat(f1, f2)
+     SCM f1, f2;
+{
+  int e, neg = 0;
+  double d1 = num2dbl(f1, (char *)ARG1, s_next_dfloat);
+  double dif = num2dbl(f2, (char *)ARG2, s_next_dfloat) - d1;
+  double d = frexp(d1, &e), eps = dbl_eps;
+  if (d1 < 0) {neg = 1; dif = -dif; d = -d;}
+  if (dif > 0) {
+#  ifdef DBL_MIN_EXP
+    if (e < DBL_MIN_EXP)
+      eps = ldexp(eps, DBL_MIN_EXP - e);
+    else if (0.0==d)
+      eps = ldexp(1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+#  endif
+    d = ldexp(d + eps, e);
+  }
+  else if (dif < 0) {
+#  ifdef DBL_MIN_EXP
+    if (e < DBL_MIN_EXP)
+      eps = ldexp(eps, DBL_MIN_EXP - e);
+    else if (0.0==d)
+      eps = ldexp(-1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+#  endif
+    if (0.5==d) eps *= 0.5;
+    d = ldexp(d - eps, e);
+  }
+  else if (0.0==dif)
+    return f1;
+  return makdbl(neg ? -d : d, 0.0);
+}
 # endif
 #endif
 
@@ -2490,6 +2652,9 @@ static iproc subr1s[] = {
 	{s_angle, angle},
 	{s_in2ex, in2ex},
 	{s_ex2in, ex2in},
+# ifdef BIGDIG
+	{s_dfloat_parts, scm_dfloat_parts},
+# endif
 #else
 	{"real?", numberp},
 	{"rational?", numberp},
@@ -2524,6 +2689,10 @@ static iproc subr2s[] = {
 	{s_makpolar, makpolar},
 	{s_atan2, latan2},
 	{s_expt, expt},
+# ifdef BIGDIG
+	{s_make_dfloat, scm_make_dfloat},
+	{s_next_dfloat, scm_next_dfloat},
+# endif
 #endif
 #ifdef INUMS_ONLY
 	{s_memv, memq},
@@ -2634,7 +2803,7 @@ void init_scl()
 # ifdef DBL_MANT_DIG
   dbl_mant_dig = DBL_MANT_DIG;
 # else
-  {
+  if (!DBL_MANT_DIG) {		/* means we #defined it. */
     double fsum = 0.0, eps = 1.0;
     int i = 0;
     while (fsum != 1.0) {
@@ -2645,5 +2814,9 @@ void init_scl()
     dbl_mant_dig = i;
   }
 # endif /* DBL_MANT_DIG */
+  max_dbl_int = pow(2.0, dbl_mant_dig - 1.0);
+  max_dbl_int = max_dbl_int + (max_dbl_int - 1.0);
+  dbl_eps = ldexp(1.0, -dbl_mant_dig);
+  sysintern("double-float-mantissa-length", MAKINUM(DBL_MANT_DIG));
 #endif
 }
diff --git a/scm.1 b/scm.1
index 3ed0590..8d5ce5b 100644
--- a/scm.1
+++ b/scm.1
@@ -1,5 +1,5 @@
 .\" dummy line
-.TH SCM "Dec 5 1998"
+.TH SCM "Jan 4 2000"
 .UC 4
 .SH NAME
 scm \- a Scheme Language Interpreter
@@ -8,30 +8,40 @@ scm \- a Scheme Language Interpreter
 [-a
 .I kbytes
 ]
-[-ibvqmu]
-[-p
-.I number
+[-muvqib]
+[--version]
+[--help]
+.br
+[[-]-no-init-file] [-p
+.I int
+] [-r
+.I feature
+] [-h
+.I feature
+]
+.br
+[-d
+.I filename
+] [-f
+.I filename
+] [-l
+.I filename
 ]
+.br
 [-c
 .I expression
-]
-[-e
+] [-e
 .I expression
 ]
-[-f
-.I filename
+[-o
+.I dumpname
 ]
-[-l
-.I filename
-]
-[-d
+.br
+[-- | - | -s] [
 .I filename
+] [
+.I arguments ...
 ]
-[-r
-.I feature
-]
-[-- | - | -s]
-[filename] [arguments ...]
 .br
 .sp 0.3
 .SH DESCRIPTION
@@ -47,6 +57,8 @@ to "Init.scm" in the source directory.
 
 Unless the option
 .I -no-init-file
+or
+.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
@@ -94,6 +106,10 @@ is 2, 3, 4, or 5
 will require the features neccessary to support R2RS, R3RS, R4RS, or
 R5RS, respectively.
 .TP
+.BI -h feature
+provides
+.I feature.
+.TP
 .BI -l filename
 .TP
 .BI -f filename
@@ -111,6 +127,18 @@ If
 contains initialization code, it will be run when the database is
 opened.
 .TP
+.BI -o dumpname
+saves the current SCM session as the executable program 
+.I dumpname.
+This option works only in SCM builds supporting 
+.BI dump.
+
+If options appear on the command line after 
+.I -o dumpname,
+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.
+.TP
 .BI -p level
 sets the prolixity (verboseness) to
 .I level.
@@ -295,9 +323,9 @@ enhancements, internal representations, and how to extend or include
 .I scm
 in other programs.
 .SH AUTHORS
-Aubrey Jaffer (jaffer @ ai.mit.edu)
+Aubrey Jaffer (jaffer @ alum.mit.edu)
 .br
-Radey Shouman (Radey.Shouman @ splashtech.com)
+Radey Shouman (shouman @ ne.mediaone.net)
 .SH BUGS
 .SH SEE ALSO
 The SCM home-page:
diff --git a/scm.c b/scm.c
index d5c1755..b939b6b 100644
--- a/scm.c
+++ b/scm.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -42,7 +42,11 @@
 /* "scm.c" Initialization and interrupt code.
    Author: Aubrey Jaffer */
 
-#include <signal.h>
+#ifdef PLAN9
+# define signal(a,b) 0/* no signals in Plan 9 */
+#else
+# include <signal.h>
+#endif
 #include "scm.h"
 #include "patchlvl.h"
 
@@ -62,7 +66,10 @@
 # ifdef SVR4
 #  include <unistd.h>
 # endif
-# ifdef __amigados__
+# ifdef __OpenBSD__
+#  include <unistd.h>
+# endif
+# ifdef __amigaos__
 #  include <unistd.h>
 # endif
 #endif
@@ -91,6 +98,7 @@ void	init_tables P((void));
 void	init_time P((void));
 void	init_types P((void));
 void	init_unif P((void));
+void	init_debug P((void));
 void	reset_time P((void));
 void	final_repl P((void));
 
@@ -103,12 +111,27 @@ This is free software, and you are welcome to redistribute it\n\
 under certain conditions; type `(terms)' for details.\n", stderr);
 }
 
+void scm_init_INITS()
+{
+  if (!dumped) {
+#ifdef INITS
+    INITS;			/* call initialization of extension files */
+#endif
+  }
+}
 SCM scm_init_extensions()
 {
 #ifdef COMPILED_INITS
   COMPILED_INITS;		/* initialize statically linked add-ons */
 #endif
   init_user_scm();
+#ifndef HAVE_DYNL
+  /* No more init_*s, so trim gra[]s */
+  scm_trim_gra(&subrs_gra);
+  scm_trim_gra(&ptobs_gra);
+  scm_trim_gra(&smobs_gra);
+  scm_trim_gra(&finals_gra);
+#endif
   return UNSPECIFIED;
 }
 
@@ -166,6 +189,10 @@ void process_signals()
     }
     mask <<= 1;
   }
+  if (gc_hook_pending) {
+    gc_hook_pending = 0;
+    scm_gc_hook();
+  }
   deferred_proc = 0;
 }
 static char s_unksig[] = "unknown signal";
@@ -239,52 +266,40 @@ SCM lalarm(i)
 # ifdef SIGPROF
 #  include <sys/time.h>
 static char s_setitimer[] = "setitimer";
-static SCM setitimer_iv[3];
+static struct {SCM sym; int which;} setitimer_tab[3] = {
+  {UNDEFINED, 0}, {UNDEFINED, 0}, {UNDEFINED, 0}};
 /* VALUE and INTERVAL are milliseconds */
 SCM scm_setitimer(which, value, interval)
      SCM which, value, interval;
 {
   struct itimerval tval, oval;
   int w;
-#  ifdef ITIMER_REAL
-  if (which==setitimer_iv[0]) {
-    w = ITIMER_REAL;
-    goto doit;
-  }
-#  endif
-#  ifdef ITIMER_VIRTUAL
-  if (which==setitimer_iv[1]) {
-    w = ITIMER_VIRTUAL;
-    goto doit;
-  }
-#  endif
-#  ifdef ITIMER_PROF
-  if (which==setitimer_iv[2]) {
-    w = ITIMER_PROF;
-    goto doit;
+  int i = sizeof(setitimer_tab)/sizeof(setitimer_tab[0]);
+  while (i--) {
+    if (which==setitimer_tab[i].sym) {
+      w = setitimer_tab[i].which;
+      if (BOOL_T==value)
+	SYSCALL(w = getitimer(w, &oval););
+      else {
+	if (BOOL_F==value) value = INUM0;
+	ASSERT(INUMP(value), value, ARG2, s_setitimer);
+	if (BOOL_F==interval) interval = INUM0;
+	ASSERT(INUMP(interval), interval, ARG3, s_setitimer);
+	tval.it_value.tv_sec = INUM(value) / 1000;
+	tval.it_value.tv_usec = (INUM(value) % 1000)*1000;
+	tval.it_interval.tv_sec = INUM(interval) / 1000;
+	tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
+	SYSCALL(w = setitimer(w, &tval, &oval););
+      }
+      if (w) return BOOL_F;
+      return cons2(MAKINUM(oval.it_value.tv_usec/1000 +
+			   oval.it_value.tv_sec*1000),
+		   MAKINUM(oval.it_interval.tv_usec/1000 +
+			   oval.it_interval.tv_sec*1000),
+		   EOL);
+    }
   }
-#  endif
   return BOOL_F;
- doit:
-  if (BOOL_T==value)
-    SYSCALL(w = getitimer(w, &oval););
-  else {
-    if (BOOL_F==value) value = INUM0;
-    ASSERT(INUMP(value), value, ARG2, s_setitimer);
-    if (BOOL_F==interval) interval = INUM0;
-    ASSERT(INUMP(interval), interval, ARG3, s_setitimer);
-    tval.it_value.tv_sec = INUM(value) / 1000;
-    tval.it_value.tv_usec = (INUM(value) % 1000)*1000;
-    tval.it_interval.tv_sec = INUM(interval) / 1000;
-    tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
-    SYSCALL(w = setitimer(w, &tval, &oval););
-  }
-  if (w) return BOOL_F;
-  return cons2(MAKINUM(oval.it_value.tv_usec/1000 +
-		       oval.it_value.tv_sec*1000),
-	       MAKINUM(oval.it_interval.tv_usec/1000 +
-		       oval.it_interval.tv_sec*1000),
-	       EOL);
 }
 # endif
 # ifndef AMIGA
@@ -301,6 +316,9 @@ SCM l_pause()
 #ifdef _WIN32
 # include <windows.h>
 #endif
+#ifdef __IBMC__
+# include <os2.h>
+#endif
 #ifndef AMIGA
 # ifndef _Windows
 static char s_sleep[] = "sleep";
@@ -313,9 +331,13 @@ SCM l_sleep(i)
   SYSCALL(sleep(INUM(i)););
 #  else
 #   ifdef _WIN32
-  Sleep(INUM(i));
+  Sleep(INUM(i) * 1000);
 #   else
+#    ifdef __IBMC__
+  DosSleep(INUM(i) * 1000);
+#    else
   SYSCALL(j = sleep(INUM(i)););
+#    endif
 #   endif
 #  endif
   return MAKINUM(j);
@@ -323,36 +345,60 @@ SCM l_sleep(i)
 # endif
 #endif
 
+#ifdef PLAN9
+int raise(sig)
+     int sig;
+{
+  char *str;
+  int len;
+  char ibuf[12];
+  char pidbuf[32];
+  int fd;
+  int res;
+  sprint(ibuf, "%ld", sig);
+  len = strlen(ibuf);
+  sprint(pidbuf, "/proc/%d/note", getpid());
+  fd = open(pidbuf, OWRITE);
+  res = write(fd, ibuf, len);
+  close (fd);
+  return res==len;
+}
+#endif
+
 #ifndef _WIN32
 # ifndef sun
 #  ifndef THINK_C
+#   ifndef __TURBOC__
+#    ifdef STDC_HEADERS
+#     ifndef __MWERKS__
+#      ifndef __IBMC__
+#       ifndef PLAN9
+#        define LACK_RAISE
+#       endif
+#      endif
+#     endif
+#    endif
+#   endif
+#  endif
+# endif
+#endif
 /* 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
+#ifdef LACK_RAISE
+# ifdef vms
   return MAKINUM(gsignal((int)INUM(sig)));
-#   else
-#    ifndef __TURBOC__
-#     ifdef STDC_HEADERS
-#      ifndef __MWERKS__
+# else
   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
-#    else
-  return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
-#    endif
-#   endif
-}
-#  endif
 # endif
+#else
+  return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
 #endif
+}
+
 #ifdef TICKS
 unsigned int tick_count = 0, ticken = 0;
 SCM *loc_tick_signal;
@@ -404,23 +450,20 @@ void init_scm(iverbose, buf0stdin, init_heap_size)
   if (!dumped) {
     init_features();
     init_subrs();
-    init_io();
     init_scl();
-    init_eval();
+    init_unif();
     init_time();
+    init_io();
+    init_eval();		/* call to scm_evstr switches INTS discipline */
+    init_debug();
+    init_rope();
     init_repl(iverbose);
-    init_unif();
   }
   else reset_time();
 #ifdef HAVE_DYNL
   /* init_dynl() must check dumped to avoid redefining subrs */
   init_dynl();
 #endif
-  if (!dumped) {
-#ifdef INITS
-    INITS;			/* call initialization of extension files */
-#endif
-  }
 }
 
 static void init_sig1(scm_err, signo, handler)
@@ -436,7 +479,9 @@ static void init_sig1(scm_err, signo, handler)
 }
 void init_signals()
 {
+#ifdef SIGINT
   init_sig1(INT_SIGNAL, SIGINT, scmable_signal);
+#endif
 #ifdef SIGHUP
   init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal);
 #endif
@@ -532,9 +577,10 @@ void restore_signals()
 # ifndef SIGPROF
   alarm(0);			/* kill any pending ALRM interrupts */
 # else
-  i = sizeof(setitimer_iv)/sizeof(SCM);
+  i = sizeof(setitimer_tab)/sizeof(setitimer_tab[0]);
   while (i--)
-    scm_setitimer(setitimer_iv[i], BOOL_F, BOOL_F);
+    if (NIMP(setitimer_tab[i].sym))
+      scm_setitimer(setitimer_tab[i].sym, BOOL_F, BOOL_F);
 # endif
 #endif
   i = NUM_SIGNALS;
@@ -567,7 +613,7 @@ void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin)
       break;
     } while (* ++str);
   }
-  init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */
+  init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in kB */
   progargs = EOL;
   progargs = makfromstrs(argc, argv);
   sysintern("*script*", script_arg ? makfrom0str(script_arg) : BOOL_F);
@@ -578,6 +624,7 @@ void final_scm(freeall)
 #ifdef TICKS
   ticken = 0;
 #endif
+  scm_run_finalizers(!0);
 #ifdef FINALS
   FINALS;			/* call shutdown of extensions files */
 #endif /* for compatability with older modules */
@@ -590,6 +637,14 @@ void final_scm(freeall)
   if (freeall) free_storage();	/* free all allocated memory */
 }
 
+#ifdef PLAN9
+# define SYSTNAME "plan9"
+# define DIRSEP "/"
+#endif
+#ifdef __MACH__
+# define SYSTNAME "unix"
+# define DIRSEP "/"
+#endif
 #ifdef __CYGWIN32__
 # define SYSTNAME "unix"
 # define DIRSEP "/"
@@ -597,7 +652,7 @@ void final_scm(freeall)
 #ifdef vms
 # define SYSTNAME "vms"
 #endif
-#ifdef unix
+#ifdef HAVE_UNIX
 # define DIRSEP "/"
 # ifndef MSDOS			/* DJGPP defines both */
 #  define SYSTNAME "unix"
@@ -613,7 +668,7 @@ void final_scm(freeall)
 #else
 # ifdef MSDOS
 #  define SYSTNAME "ms-dos"
-#  ifndef unix
+#  ifndef HAVE_UNIX
 #   define DIRSEP "\\"
 #  endif
 # endif
@@ -642,17 +697,13 @@ void final_scm(freeall)
 # define SYSTNAME "atarist"
 # define DIRSEP "\\"
 #endif
-#ifdef mach
-# define SYSTNAME "mach"
-# define DIRSEP "/"
-#endif
 #ifdef ARM_ULIB
 # define SYSTNAME "acorn"
 #endif
 #ifdef nosve
 # define DIRSEP "."
 #endif
-#ifdef __amigados__
+#ifdef __amigaos__
 # define SYSTNAME "amiga"
 # define DIRSEP "/"
 #endif
@@ -667,6 +718,36 @@ SCM softtype()
 #endif
 }
 
+#ifdef PLAN9
+/* This code is adapted from /sys/src/ape/lib/ap/plan9/isatty.c. */
+int isatty (int fd)
+{
+  Dir d1, d2;
+  char buf[40];
+  int t;
+  if (dirfstat(fd, &d1) < 0) return 0;
+  if (strncmp(d1.name, "ptty", 4) == 0) return 1;
+  if (dirstat("/dev/cons", &d2) < 0) return 0;
+  /* If we came in through con, /dev/cons is probably #d/0, which won't
+   * match stdin.  Opening #d/0 and fstating it gives the values of the
+   * underlying channel */
+  if (d2.type == 'd') {
+    strcpy(buf, "#d/");
+    strcpy(buf+3, d2.name);
+    if ((t = open(buf, 0)) < 0) return 0;
+    if (dirfstat(t, &d2) < 0) {
+      close(t);
+      return 0;
+    }
+    close(t);
+  }
+  return (d1.type == d2.type) && (d1.dev == d2.dev);
+}
+
+/* A temporary hack: give SCM our own errno. */
+int errno;
+#endif
+
 int init_buf0(inport)
      FILE *inport;
 {
@@ -719,7 +800,7 @@ char *scm_find_execpath(argc, argv, script_arg)
 {
   char *exepath = 0;
 #ifndef macintosh
-# ifdef unix
+# ifdef HAVE_UNIX
 #  ifndef MSDOS
   if (script_arg) exepath = script_find_executable(script_arg);
 #  endif
@@ -730,6 +811,26 @@ char *scm_find_execpath(argc, argv, script_arg)
   return exepath;
 }
 
+#ifdef PLAN9
+int system(command)
+     const char *command;
+{
+  int sts;
+  int pid = fork();
+  if (pid) {
+    Waitmsg wm;
+    sts = -1;
+    while (wait(&wm) != -1) {
+      if (pid==atoi(wm.pid)) {
+	sts = 0;
+	break;
+      }
+    }
+  } else sts = execl("/bin/rc", "/bin/rc", "-c", command, nil);
+  return sts;
+}
+#endif
+
 #ifndef _Windows
 char s_system[] = "system";
 SCM lsystem(cmd)
@@ -838,9 +939,18 @@ void init_features()
 #ifdef SIGALRM
 # ifdef SIGPROF
   make_subr(s_setitimer, tc7_subr_3, scm_setitimer);
-  setitimer_iv[0] = CAR(sysintern("real", UNDEFINED));
-  setitimer_iv[1] = CAR(sysintern("virtual", UNDEFINED));
-  setitimer_iv[2] = CAR(sysintern("profile", UNDEFINED));
+#  ifdef ITIMER_REAL
+  setitimer_tab[0].sym = CAR(sysintern("real", UNDEFINED));
+  setitimer_tab[0].which = ITIMER_REAL;
+#  endif
+#  ifdef ITIMER_VIRTUAL
+  setitimer_tab[1].sym = CAR(sysintern("virtual", UNDEFINED));
+  setitimer_tab[1].which = ITIMER_VIRTUAL;
+#  endif
+#  ifdef ITIMER_PROF
+  setitimer_tab[2].sym = CAR(sysintern("profile", UNDEFINED));
+  setitimer_tab[2].which = ITIMER_PROF;
+#  endif
 # endif
 #endif
 #ifdef TICKS
@@ -856,5 +966,5 @@ void init_features()
 #ifdef vms
   add_feature(s_ed);
 #endif
-  sysintern("*scm-version*", makfrom0str(SCMVERSION));
+  sysintern("*scm-version*", CAR(sysintern(SCMVERSION, UNDEFINED)));
 }
diff --git a/scm.doc b/scm.doc
index 03488a5..2367bc0 100644
--- a/scm.doc
+++ b/scm.doc
@@ -1,49 +1,50 @@
 
 
 
-SCM(Dec 5 1998)                                   SCM(Dec 5 1998)
+SCM(Jan 4 2000)                                   SCM(Jan 4 2000)
 
 
 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
-       ...]
+       scm [-a kbytes ] [-muvqib] [--version] [--help]
+       [[-]-no-init-file] [-p int ] [-r feature ] [-h feature ]
+       [-d filename ] [-f filename ] [-l filename ]
+       [-c expression ] [-e expression ] [-o dumpname ]
+       [-- | - | -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
+       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
+       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
+       Unless  the  option -no-init-file or --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 environ-
+       ment 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
+       "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
+       The  options  are  processed in the order specified on the
        command line.
 
        -akbytes
-            specifies  that  scm should allocate an initial heap-
+            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
+            Inhibits the loading of  "ScmInit.scm"  as  described
             above.
 
        -eexpression
@@ -51,13 +52,12 @@ OPTIONS
        -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
+            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
 
 
 
@@ -67,103 +67,118 @@ OPTIONS
 
 
 
-SCM(Dec 5 1998)                                   SCM(Dec 5 1998)
+SCM(Jan 4 2000)                                   SCM(Jan 4 2000)
 
 
-            2, 3, 4, or 5 scm will require the  features  necces-
-            sary  to  support  R2RS, R3RS, R4RS, or R5RS, respec-
+            that feature is not already supported.  If feature is
+            2,  3,  4, or 5 scm will require the features necces-
+            sary to support R2RS, R3RS, R4RS,  or  R5RS,  respec-
             tively.
 
+       -hfeature
+            provides feature.
+
        -lfilename
 
        -ffilename
             loads filename.  Scm will load the first (unoptioned)
-            file  named on the command line if no -c, -e, -f, -l,
+            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,
+            opens  (read-only)  the  extended relational database
+            filename.  If filename contains initialization  code,
             it will be run when the database is opened.
 
+       -odumpname
+            saves  the current SCM session as the executable pro-
+            gram dumpname.  This option works only in SCM  builds
+            supporting dump.
+
+            If  options appear on the command line after -o dump-
+            name, then the saved session will continue with  pro-
+            cessing  those options when it is invoked.  Otherwise
+            the (new) command line is processed as usual when the
+            saved image is invoked.
+
        -plevel
-            sets the prolixity (verboseness) to level.   This  is
+            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
+            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
+       -q   (quiet  mode)  specifies that scm will print no extra
             information.  This is the same as -p0.
 
-       -m   specifies  that  subsequent  loads,  evaluations, and
+       -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
+       -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
 
 
-                                                                2
 
 
 
+SCM(Jan 4 2000)                                   SCM(Jan 4 2000)
 
 
-SCM(Dec 5 1998)                                   SCM(Dec 5 1998)
+       -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
             are to be treated as program aguments.
 
-       -    --  specifies  that  there are no more options on the
+       -    -- 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
+            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
+       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
+            *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
+            fied  on the command line.  This can be overridden by
             subsequent -m and -u options.
 
        *interactive*
@@ -173,39 +188,41 @@ SCHEME VARIABLES
             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
 
 
 
-                                                                3
 
 
+SCM(Jan 4 2000)                                   SCM(Jan 4 2000)
 
 
+       % 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(Dec 5 1998)                                   SCM(Dec 5 1998)
+       % 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
             mode.
 
        % scm -r5
-            Load dynamic-wind, values, and R4RS macros and  enter
+            Load  dynamic-wind, values, and R4RS macros and enter
             interactive (with macros) mode.
 
        % scm -r5 -r4
@@ -213,73 +230,73 @@ SCM(Dec 5 1998)                                   SCM(Dec 5 1998)
             loaded.
 
 FEATURES
-       Runs under Amiga, Atari-ST, MacOS, MS-DOS,  OS/2,  NOS/VE,
-       Unicos,  VMS, Unix and similar systems.  Support for ASCII
+       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^5 Report on the  Algorithmic  Language
+       Conforms  to  Revised^5 Report on the Algorithmic Language
        Scheme and the IEEE P1178 specification.
 
        Support for SICP, R2RS, R3RS, and R4RS 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,
+       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.
+       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
+       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.
+       User  definable  responses  to interrupts and errors, Pro-
+       cess-syncronization primitives, String regular  expression
 
-       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.
+                                                                4
 
-FILES
-       scm.texi
-              Texinfo documentation of scm enhancements, internal
-              representations, and how to extend or  include  scm
 
 
 
-                                                                4
 
+SCM(Jan 4 2000)                                   SCM(Jan 4 2000)
 
 
+       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.
 
-SCM(Dec 5 1998)                                   SCM(Dec 5 1998)
+       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
+       scm.texi
+              Texinfo documentation of scm enhancements, internal
+              representations,  and  how to extend or include scm
               in other programs.
 
 AUTHORS
-       Aubrey Jaffer (jaffer @ ai.mit.edu)
-       Radey Shouman (Radey.Shouman @ splashtech.com)
+       Aubrey Jaffer (jaffer @ alum.mit.edu)
+       Radey Shouman (shouman @ ne.mediaone.net)
 
 BUGS
 SEE ALSO
        The SCM home-page:
        http://swissnet.ai.mit.edu/~jaffer/SCM.html
 
-       The  Scheme  specifications for details on specific proce-
+       The Scheme specifications for details on  specific  proce-
        dures  (http://swissnet.ai.mit.edu/ftpdir/scheme-reports/)
        or
 
@@ -308,23 +325,6 @@ SEE ALSO
 
 
 
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
                                                                 5
 
 
diff --git a/scm.h b/scm.h
index 03c2ee3..81b6232 100644
--- a/scm.h
+++ b/scm.h
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -51,6 +51,16 @@ extern "C" {
 # endif
 #endif
 
+#ifdef PLAN9
+# include <u.h>
+# include <libc.h>
+/* Simple imitation of some Unix system calls */
+# define exit(val) exits("")
+# define getcwd getwd
+/* we have our own isatty */
+int isatty (int);
+#endif
+
 typedef long SCM;
 typedef struct {SCM car, cdr;} cell;
 typedef struct {long sname;SCM (*cproc)();} subr;
@@ -100,15 +110,17 @@ typedef struct {
   int	(*fflush)P((FILE *stream));
   int	(*fgetc)P((FILE *p));
   int	(*fclose)P((FILE *p));
+  int	(*ungetc)P((int c, SCM p));
 } ptobfuns;
 
 typedef struct {
+  SCM data;
+  SCM port;
   long flags;
-  int unread;
   long line;
+  int unread;
   short col;
   short colprev;
-  SCM data;
 } port_info;
 
 typedef struct {
@@ -143,16 +155,13 @@ typedef struct {SCM type;double *real;} dbl;
 #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 MAKILOC(if, id) (ILOC00 + (((long)id)<<20) + (((long)if)<<8))
-#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8))
-#define IDIST(n) (((unsigned long)(n))>>20)
+#define ILOCP(n) ((0xff & (int)(n))==(int)ILOC00)
+#define MAKILOC(if, id) (ILOC00 + (((long)id)<<8) + (((long)if)<<16))
+#define IDIST(n) (((int)(n)>>8) & 0x7f)
+#define IFRAME(n) (((int)(n)>>16))
 #define ICDRP(n) (ICDR & (n))
+#define ICDR (1L<<15)
 
 /* ISYMP tests for ISPCSYM and ISYM */
 #define ISYMP(n) ((0x187 & (int)(n))==4)
@@ -165,6 +174,9 @@ typedef struct {SCM type;double *real;} dbl;
 #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
 #define MAKISYM(n) (((n)<<9)+0x74L)
 #define MAKIFLAG(n) (((n)<<9)+0x174L)
+/* This is to make the print representation of some evaluated code,
+   as in backtraces, make a little more sense. */
+#define MAKSPCSYM2(work, look) ((127L & (work)) | ((127L<<9) & (look)))
 
 extern char *isymnames[];
 #define NUM_ISPCSYM 14
@@ -181,7 +193,7 @@ extern char *isymnames[];
 #define IM_OR MAKSPCSYM(10)
 #define IM_QUOTE MAKSPCSYM(11)
 #define IM_SET MAKSPCSYM(12)
-#define IM_DEFINE MAKSPCSYM(13)
+#define IM_FUNCALL MAKSPCSYM(13)
 
 #define s_and (ISYMCHARS(IM_AND)+2)
 #define s_begin (ISYMCHARS(IM_BEGIN)+2)
@@ -199,23 +211,38 @@ extern char *isymnames[];
 #define s_define (ISYMCHARS(IM_DEFINE)+2)
 #define s_delay (ISYMCHARS(IM_DELAY)+2)
 #define s_quasiquote (ISYMCHARS(IM_QUASIQUOTE)+2)
+#define s_let_syntax (ISYMCHARS(IM_LET_SYNTAX)+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 */
+/* each symbol defined here must have a unique number which
+   corresponds to it's position in isymnames[] in repl.c */
+  /* These are used for dispatch in eval.c */
 #define IM_APPLY MAKISYM(14)
 #define IM_FARLOC_CAR MAKISYM(15)
 #define IM_FARLOC_CDR MAKISYM(16)
 #define IM_DELAY MAKISYM(17)
 #define IM_QUASIQUOTE MAKISYM(18)
-#define IM_UNQUOTE MAKISYM(19)
-#define IM_UQ_SPLICING MAKISYM(20)
-#define IM_ELSE MAKISYM(21)
-#define IM_ARROW MAKISYM(22)
-
-#define NUM_ISYMS 23
+#define IM_EVAL_FOR_APPLY MAKISYM(19)
+#define IM_LET_SYNTAX MAKISYM(20)
+#define IM_ACRO_CALL MAKISYM(21)
+#define IM_LINUM MAKISYM(22)
+#define IM_DEFINE MAKISYM(23)
+
+  /* These are not used for dispatch. */
+#define IM_UNQUOTE MAKISYM(24)
+#define IM_UQ_SPLICING MAKISYM(25)
+#define IM_ELSE MAKISYM(26)
+#define IM_ARROW MAKISYM(27)
+#define IM_VALUES_TOKEN MAKISYM(28)
+#define IM_KEYWORD MAKISYM(29)
+
+#define SCM_MAKE_LINUM(n) (IM_LINUM | ((unsigned long)(n))<<16)
+#define SCM_LINUM(x) ((unsigned long)(x)>>16)
+#define SCM_LINUMP(x) ((0xffffL & (x))==IM_LINUM)
+
+#define NUM_ISYMS 30
 
 #define BOOL_F MAKIFLAG(NUM_ISYMS+0)
 #define BOOL_T MAKIFLAG(NUM_ISYMS+1)
@@ -267,6 +294,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 #define CONSP(x) (!NCONSP(x))
 #define ECONSP(x) (CONSP(x) || (1==TYP3(x)))
 #define NECONSP(x) (NCONSP(x) && (1 != TYP3(x)))
+#define SCM_GLOCP(x) (tc3_cons_gloc==(7 & (int)(x)))
 
 #define CAR(x) (((cell *)(SCM2PTR(x)))->car)
 #define CDR(x) (((cell *)(SCM2PTR(x)))->cdr)
@@ -280,16 +308,39 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 #define GCENV ENV
 #define ARGC(x) ((6L & CDR(x))>>1)
 #ifdef CAUTIOUS
-# define SCM_ESTK_FRLEN 3
+# define SCM_ESTK_FRLEN 4
 #else
-# define SCM_ESTK_FRLEN 2
+# define SCM_ESTK_FRLEN 3
 #endif
 #define SCM_ESTK_BASE 4
 #define SCM_ESTK_PARENT(v) (VELTS(v)[0])
 #define SCM_ESTK_PARENT_WRITABLEP(v) (VELTS(v)[1])
 #define SCM_ESTK_PARENT_INDEX(v) (VELTS(v)[2])
-extern long tc16_env;
+extern long tc16_env, tc16_ident;
 #define ENVP(x) (tc16_env==TYP16(x))
+#define SCM_ENV_FORMALS CAR
+#ifdef MACRO
+# define M_IDENTP(x) (tc16_ident==TYP16(x))
+# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
+# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
+# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x))
+# define IDENT_ENV(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F)
+#else
+# define IDENTP SYMBOLP
+# define M_IDENTP(x) (0)
+#endif
+
+  /* markers for various static environment frame types */
+  /* FIXME these need to be exported somehow to Scheme */
+#ifdef CAUTIOUS
+# define SCM_ENV_FILENAME MAKINUM(1)
+# define SCM_ENV_PROCNAME MAKINUM(2)
+#endif
+#define SCM_ENV_DOC MAKINUM(3)
+#define SCM_ENV_ANNOTATION MAKINUM(4)
+#define SCM_ENV_CONSTANT MAKINUM(5)
+#define SCM_ENV_SYNTAX MAKINUM(6)
+#define SCM_ENV_END MAKINUM(7)
 
 #define PORTP(x) (TYP7(x)==tc7_port)
 #define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
@@ -354,7 +405,7 @@ extern long tc16_env;
 #define MAKE_NUMDIGS(v, t) ((((v)+0L)<<16)+(t))
 #define SETNUMDIGS(x, v, t) CAR(x) = MAKE_NUMDIGS(v, t)
 
-#define SNAME(x) ((char *)(subr_table[NUMDIGS(x)].name))
+#define SNAME(x) ((char *)(subrs[NUMDIGS(x)].name))
 #define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc)
 #define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc)
 #define CCLO_SUBR(x) (VELTS(x)[0])
@@ -392,26 +443,37 @@ extern long tc16_array;
 #define SMOBNUM(x) (0x0ff & (CAR(x)>>8))
 #define PTOBNUM(x) (0x0ff & (CAR(x)>>8))
 #define SCM_PORTNUM(x) ((int)(((unsigned long)CAR(x))>>20))
+#define SCM_PORTNUM_MAX ((int)((0x7fffUL<<20)>>20))
 #define SCM_PORTFLAGS(x) (scm_port_table[SCM_PORTNUM(x)].flags)
 #define SCM_PORTDATA(x) (scm_port_table[SCM_PORTNUM(x)].data)
+#define SCM_SETFLAGS(x, flags) (CAR(x) = (CAR(x) & ~0x0f0000L) | (flags))
+/* This is used (only) for closing ports. */
+#define SCM_SET_PTOBNUM(x, typ) (CAR(x)=(typ)|(CAR(x) & ~0x0ffffL))
 
 #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_inum 2: case 6:case 10:case 14:\
+		 case 18:case 22:case 26:case 30:\
+		 case 34:case 38:case 42:case 46:\
+		 case 50:case 54:case 58:case 62:\
+		 case 66:case 70:case 74:case 78:\
+		 case 82:case 86:case 90:case 94:\
+		 case 98:case 102:case 106:case 110:\
+		 case 114:case 118:case 122:case 126
+#define tcs_cons_iloc 124
+#define tcs_cons_ispcsym 4:case 12:case 20:case 28:\
+		   case 36:case 44:case 52:case 60:\
+		   case 68:case 76:case 84:case 92:\
+		   case 100:case 108
+#define tcs_cons_chflag 116	/* char *or* flag */
+#define tcs_cons_imcar tcs_cons_inum:\
+		   case tcs_cons_iloc:\
+		   case tcs_cons_ispcsym:\
+		   case tcs_cons_chflag
+
 #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:\
@@ -438,6 +500,7 @@ extern long tc16_array;
 #define tc3_cons_imcar  2:case 4:case 6
 #define tc3_cons_gloc	1
 #define tc3_closure	3
+#define tc3_tc7_types	5:case 7
 
 #define tc7_ssymbol	5
 #define tc7_msymbol	7
@@ -477,6 +540,8 @@ extern long tc16_array;
 #define tc16_call_cc	(tc7_specfun | (1L<<8))
 #define tc16_cclo	(tc7_specfun | (2L<<8))
 #define tc16_eval	(tc7_specfun | (3L<<8))
+#define tc16_values	(tc7_specfun | (4L<<8))
+#define tc16_call_wv	(tc7_specfun | (5L<<8))
 
 #define tc16_flo	0x017f
 #define tc_flo		0x017fL
@@ -489,17 +554,21 @@ extern long tc16_array;
 #define tc16_bigpos	0x027f
 #define tc16_bigneg	0x037f
 
+  /* The first four flags fit in the car of a port cell, remaining
+   flags only in the port table */
 #define OPN		(1L<<16)
 #define RDNG		(2L<<16)
 #define WRTNG		(4L<<16)
 #define CRDY		(8L<<16)
+
 #define TRACKED		(16L<<16)
 #define BINARY		(32L<<16)
 #define BUF0		(64L<<16)
+#define EXCLUSIVE	(128L<<16)
 		/* LSB is used for gc mark */
 
-extern scm_gra subr_table_gra;
-#define subr_table ((subr_info *)(subr_table_gra.elts))
+extern scm_gra subrs_gra;
+#define subrs ((subr_info *)(subrs_gra.elts))
 /* extern sizet numsmob, numptob;
   extern smobfuns *smobs;
   extern ptobfuns *ptobs;
@@ -517,30 +586,32 @@ extern port_info *scm_port_table;
 #define tc16_strport (tc7_port + 2*256L)
 #define tc16_sfport (tc7_port + 3*256L)
 extern long tc16_dir;
+extern long tc16_clport;
 
 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 sys_errp sys_protects[6]
-#define sys_safep sys_protects[7]
-#define listofnull sys_protects[8]
-#define undefineds sys_protects[9]
-#define nullvect sys_protects[10]
-#define nullstr sys_protects[11]
-#define progargs sys_protects[12]
-#define loadports sys_protects[13]
-#define rootcont sys_protects[14]
-#define dynwinds sys_protects[15]
-#ifdef FLOATS
-# define flo0 sys_protects[16]
-# define NUM_PROTECTS 17
-#else
-# define NUM_PROTECTS 16
-#endif
+#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 sys_errp 	 sys_protects[6]
+#define sys_safep  	 sys_protects[7]
+#define listofnull 	 sys_protects[8]
+#define undefineds 	 sys_protects[9]
+#define nullvect   	 sys_protects[10]
+#define nullstr    	 sys_protects[11]
+#define progargs  	 sys_protects[12]
+#define loadports 	 sys_protects[13]
+#define rootcont  	 sys_protects[14]
+#define dynwinds  	 sys_protects[15]
+#define list_unspecified sys_protects[16]
+#define f_evapply	 sys_protects[17]
+#define eval_env	 sys_protects[18]
+#define f_apply_closure  sys_protects[19]
+#define flo0		 sys_protects[20]
+#define scm_uprotects	 sys_protects[21]
+#define NUM_PROTECTS 22
 
 /* now for connects between source files */
 
@@ -565,7 +636,7 @@ extern SCM *loc_loadpath;
 extern SCM *loc_errobj;
 extern SCM loadport;
 extern char *errjmp_bad;
-extern int ints_disabled, output_deferred;
+extern int ints_disabled, output_deferred, gc_hook_pending, gc_hook_active;
 extern unsigned long SIG_deferred;
 extern SCM exitval;
 extern int cursinit;
@@ -593,6 +664,8 @@ extern char s_close_port[];
 #define s_port_type (s_close_port+6)
 extern char s_call_cc[];
 #define s_cont (s_call_cc+18)
+extern char s_try_create_file[];
+extern char s_badenv[];
 
 /* function prototypes */
 
@@ -618,24 +691,47 @@ SCM	lflush P((SCM port));
 void	scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len,
 			sizet maxlen, char *what));
 int	scm_grow_gra P((scm_gra *gra, char *elt));
+void	scm_trim_gra P((scm_gra *gra));
 void	scm_free_gra P((scm_gra *gra));
 long	newsmob P((smobfuns *smob));
 long	newptob P((ptobfuns *ptob));
-SCM	scm_port_entry P((long ptype, long flags));
+SCM	scm_port_entry P((FILE *stream, long ptype, long flags));
+SCM	scm_open_ports P((void));
 void	prinport P((SCM exp, SCM port, char *type));
 SCM	repl P((void));
+void	repl_report P((void));
 void	growth_mon P((char *obj, long size, char *units, int grewp));
 void	gc_start P((char *what));
 void	gc_end P((void));
 void	gc_mark P((SCM p));
+void	scm_gc_hook P((void));
+SCM     scm_gc_protect P((SCM obj));
+SCM	scm_add_finalizer P((SCM value, SCM finalizer));
+void	scm_run_finalizers P((int exiting));
 void    scm_egc_start P((void));
 void    scm_egc_end P((void));
 void	heap_report P((void));
+void	gra_report P((void));
 void	exit_report P((void));
 void	stack_report P((void));
+SCM	scm_stack_trace P((SCM contin));
+SCM	scm_scope_trace P((SCM env));
+SCM	scm_frame_trace P((SCM contin, SCM nf));
+SCM	scm_frame2env P((SCM contin, SCM nf));
+SCM	scm_frame_eval P((SCM contin, SCM nf, SCM expr));
 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));
+SCM	scm_env_lookup P((SCM var, SCM stenv));
+SCM	scm_env_rlookup P((SCM addr, SCM stenv, char *what));
+SCM	scm_env_getprop P((SCM prop, SCM env));
+SCM	scm_env_addprop P((SCM prop, SCM val, SCM env));
+long	num_frames P((SCM estk, int i));
+SCM	*estk_frame P((SCM estk, int i, int nf));
+SCM	*cont_frame P((SCM contin, int nf));
+SCM	stacktrace1 P((SCM estk, int i));
+void	scm_princode P((SCM code, SCM env, SCM port, int writing));
+void	scm_princlosure P((SCM proc, SCM port, int writing));
 void	lputc P((int c, SCM port));
 void	lputs P((char *s, SCM port));
 sizet	lfwrite P((char *ptr, sizet size, sizet nitems, SCM port));
@@ -648,6 +744,7 @@ SCM	my_time P((void));
 SCM	your_time P((void));
 void	init_iprocs P((iproc *subra, int type));
 
+void	final_scm P((int));
 void	init_sbrk P((void));
 int	init_buf0 P((FILE *inport));
 void	scm_init_from_argv P((int argc, char **argv, char *script_arg,
@@ -659,6 +756,7 @@ void	free_storage P((void));
 char	*dld_find_executable P((const char* command));
 char	*scm_find_execpath P((int argc, char **argv, char *script_arg));
 void	init_scm P((int iverbose, int buf0stdin, long init_heap_size));
+void    scm_init_INITS P((void));
 SCM	scm_init_extensions P((void));
 void	init_user_scm P((void));
 void	ignore_signals P((void));
@@ -670,16 +768,17 @@ SCM	markcdr P((SCM ptr));
 #define mark0 (0)    /*SCM mark0 P((SCM ptr)); */
 SCM	equal0 P((SCM ptr1, SCM ptr2));
 sizet	free0 P((CELLPTR ptr));
-void	scm_warn P((char *str1, char *str2));
-void	everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr));
+void	scm_warn P((char *str1, char *str2, SCM obj));
+void	everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr, int codep));
 void	wta P((SCM arg, char *pos, char *s_subr));
+void	scm_experr P((SCM arg, char *pos, char *s_subr));
 SCM	intern P((char *name, sizet len));
 SCM	sysintern P((const char *name, SCM val));
 SCM	sym2vcell P((SCM sym));
 SCM	makstr P((long len));
 SCM	scm_maksubr P((const char *name, int type, SCM (*fcn)()));
 SCM	make_subr P((const char *name, int type, SCM (*fcn)()));
-SCM	make_synt P((const char *name, SCM (*macroizer)(), SCM (*fcn)()));
+SCM	make_synt P((const char *name, long flags, SCM (*fcn)()));
 SCM	make_gsubr P((const char *name, int req, int opt, int rst,
 		      SCM (*fcn)()));
 SCM	closure P((SCM code, int nargs));
@@ -688,12 +787,14 @@ 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	ceval P((SCM x, SCM static_env, SCM env));
+SCM	scm_wrapcode P((SCM code, SCM env));
+SCM	scm_current_env P((void));
 SCM	prolixity P((SCM arg));
 SCM	gc_for_newcell P((void));
 void	gc_for_open_files P((void));
 SCM	gc P((SCM arg));
-SCM	tryload P((SCM filename));
+SCM	tryload P((SCM filename, SCM reader));
 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));
@@ -725,6 +826,9 @@ 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	greaterp P((SCM x, SCM y));
+SCM	leqp P((SCM x, SCM y));
+SCM	greqp P((SCM x, SCM y));
 SCM	zerop P((SCM z));
 SCM	positivep P((SCM x));
 SCM	negativep P((SCM x));
@@ -811,11 +915,16 @@ 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	scm_values P((SCM arg1, SCM arg2, SCM rest, char *what));
+SCM	scm_eval_values P((SCM x, SCM static_env, SCM env));
 SCM	identp P((SCM obj));
 SCM	ident2sym P((SCM id));
 SCM	ident_eqp P((SCM id1, SCM id2, SCM env));
+int	scm_nullenv_p P((SCM env));
 SCM	env2tree P((SCM env));
 SCM	renamed_ident P((SCM id, SCM env));
+SCM	scm_check_linum P((SCM x, SCM *linum));
+SCM	scm_add_linum P((SCM linum, SCM x));
 SCM	input_portp P((SCM x));
 SCM	output_portp P((SCM x));
 SCM	cur_input_port P((void));
@@ -829,6 +938,7 @@ SCM	lread P((SCM port));
 SCM	scm_read_char P((SCM port));
 SCM	peek_char P((SCM port));
 SCM	eof_objectp P((SCM x));
+int	scm_io_error P((SCM port, char *what));
 SCM	lwrite P((SCM obj, SCM port));
 SCM	display P((SCM obj, SCM port));
 SCM	newline P((SCM port));
@@ -837,11 +947,14 @@ SCM	file_position P((SCM port));
 SCM	file_set_position P((SCM port, SCM pos));
 SCM	scm_port_line P((SCM port));
 SCM	scm_port_col P((SCM port));
+void	scm_line_msg P((SCM file, SCM linum, SCM port));
+void	scm_err_line P((char *what, SCM file, SCM linum, SCM port));
 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));
+SCM	makidmacro P((SCM code));
 void	poll_routine P((void));
 void	tick_signal P((void));
 void	stack_check P((void));
@@ -941,6 +1054,7 @@ long	 pseudolong P((long x));
 #endif
 int	bigcomp P((SCM x, SCM y));
 SCM	bigequal P((SCM x, SCM y));
+int	scm_bigdblcomp P((SCM b, double d));
 
 /* "script.c" functions */
 char *	scm_cat_path P((char *str1, const char *str2, long n));
@@ -956,9 +1070,9 @@ void scm_ecache_report P((void));
 void scm_estk_reset P((sizet size));
 void scm_env_cons P((SCM x, SCM y));
 void scm_env_cons2 P((SCM w, SCM x, SCM y));
-void scm_env_cons_tmp P((SCM x));
-void scm_env_v2lst P((int argc, SCM *argv));
-void scm_extend_env P((SCM names));
+void scm_env_cons3 P((SCM v, SCM w, SCM x, SCM y));
+void scm_env_v2lst P((long argc, SCM *argv));
+void scm_extend_env P((void));
 void scm_egc P((void));
 
 /* Global state for environment cache */
@@ -968,8 +1082,11 @@ extern SCM scm_env, scm_env_tmp;
 extern SCM scm_egc_roots[];
 extern VOLATILE long scm_egc_root_index;
 extern SCM scm_estk;
-extern  SCM *scm_estk_v, *scm_estk_ptr;
+extern SCM *scm_estk_v, *scm_estk_ptr;
 extern long scm_estk_size;
+#ifndef RECKLESS
+extern SCM scm_trace, scm_trace_env;
+#endif
 
 #ifdef RECKLESS
 # define ASSERT(_cond, _arg, _pos, _subr) ;
@@ -1001,8 +1118,8 @@ extern long scm_estk_size;
 #define VTALRM_SIGNAL   19
 #define PROF_SIGNAL	20
 
-#define EVAL(x, env) (IMP(x)?(x):ceval((x), (env)))
-#define SIDEVAL(x, env) if NIMP(x) ceval((x), (env))
+#define EVAL(x, env, venv) (IMP(x)?(x):ceval((x), (SCM)(env), (SCM)(venv)))
+#define SIDEVAL(x, env, venv) if NIMP(x) ceval((x), (SCM)(env), (SCM)(venv))
 
 #define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\
 	else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
diff --git a/scm.info b/scm.info
index 421167d..b0dbf1b 100644
--- a/scm.info
+++ b/scm.info
@@ -1,5 +1,4 @@
-This is Info file scm.info, produced by Makeinfo version 1.68 from the
-input file scm.texi.
+This is scm.info, produced by makeinfo version 4.0 from scm.texi.
 
 INFO-DIR-SECTION The Algorithmic Language Scheme
 START-INFO-DIR-ENTRY
@@ -9,11 +8,11 @@ END-INFO-DIR-ENTRY
 
 File: scm.info,  Node: Top,  Next: Overview,  Prev: (dir),  Up: (dir)
 
-This manual documents the SCM Scheme implementation.  SCM version             |
-5d2 was released December 1999.  The most recent information about SCM        |
-can be found on SCM's "WWW" home page:                                        |
+This manual documents the SCM Scheme implementation.  SCM version
+5d6 was released April 2002.  The most recent information about SCM can       |
+be found on SCM's "WWW" home page:                                            |
 
-             `http://swissnet.ai.mit.edu/~jaffer/SCM.html'
+             <http://swissnet.ai.mit.edu/~jaffer/SCM.html>
 
 Copyright (C) 1990-1999 Free Software Foundation
 
@@ -52,82 +51,13 @@ machine independent platform for [JACAL], a symbolic algebra system.
 
 * Menu:
 
-* Copying::
 * SCM Features::
 * SCM Authors::
+* Copying::
 * Bibliography::
 
 
-File: scm.info,  Node: Copying,  Next: SCM Features,  Prev: Overview,  Up: Overview
-
-Copying
-=======
-
-                         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
-                                                    Phone: 617-492-6079
-
-Paradigm Associates Inc
-29 Putnam Ave, Suite 6
-Cambridge, MA 02138
-
-           Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995
-
-                    Free Software Foundation, Inc.
-
-           59 Temple Place, Suite 330, Boston, MA 02111, USA
-
-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.
-
-                              NO WARRANTY
-
-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.
-
-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.
-
-
-File: scm.info,  Node: SCM Features,  Next: SCM Authors,  Prev: Copying,  Up: Overview
+File: scm.info,  Node: SCM Features,  Next: SCM Authors,  Prev: Overview,  Up: Overview
 
 Features
 ========
@@ -177,16 +107,16 @@ Features
      function).  `Restart', `quit', and `exec'.
 
 
-File: scm.info,  Node: SCM Authors,  Next: Bibliography,  Prev: SCM Features,  Up: Overview
+File: scm.info,  Node: SCM Authors,  Next: Copying,  Prev: SCM Features,  Up: Overview
 
 Authors
 =======
 
-Aubrey Jaffer (jaffer @ ai.mit.edu)
+Aubrey Jaffer (jaffer @ alum.mit.edu)                                         |
      Most of SCM.
 
 Radey Shouman
-     Arrays. `gsubr's, compiled closures, records, Ecache, syntax-rules
+     Arrays, `gsubr's, compiled closures, records, Ecache, syntax-rules
      macros, and "safeport"s.
 
 Jerry D. Hedden
@@ -200,13 +130,87 @@ George Carrette
      "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
-     (*note Garbage Collection::.).
+     (*note Garbage Collection::).
 
 There are many other contributors to SCM.  They are acknowledged in the
 file `ChangeLog', a log of changes that have been made to scm.
 
 
-File: scm.info,  Node: Bibliography,  Prev: SCM Authors,  Up: Overview
+File: scm.info,  Node: Copying,  Next: Bibliography,  Prev: SCM Authors,  Up: Overview
+
+Copyright
+=========
+
+Authors have assigned their SCM copyrights to:
+
+
+                    Free Software Foundation, Inc.
+
+           59 Temple Place, Suite 330, Boston, MA 02111, USA
+
+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.
+
+                              NO WARRANTY
+
+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.
+
+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.
+
+SIOD copyright
+==============
+
+
+                         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
+                                                    Phone: 617-492-6079
+
+Paradigm Associates Inc
+29 Putnam Ave, Suite 6
+Cambridge, MA 02138
+
+
+File: scm.info,  Node: Bibliography,  Prev: Copying,  Up: Overview
 
 Bibliography
 ============
@@ -215,15 +219,6 @@ Bibliography
      `IEEE Standard 1178-1990.  IEEE Standard for the Scheme
      Programming Language.'  IEEE, New York, 1991.
 
-[Simply]
-     Brian Harvey and Matthew Wright.  `Simply Scheme: Introducing
-     Computer Science' MIT Press, 1994 ISBN 0-262-08226-8
-
-[SICP]
-     Harold Abelson and Gerald Jay Sussman with Julie Sussman.
-     `Structure and Interpretation of Computer Programs.'  MIT Press,
-     Cambridge, 1985.
-
 [R4RS]
      William Clinger and Jonathan Rees, Editors.  Revised(4) Report on
      the Algorithmic Language Scheme.  `ACM Lisp Pointers' Volume IV,
@@ -243,19 +238,28 @@ Bibliography
      William Clinger Hygienic Macros Through Explicit Renaming `Lisp
      Pointers' Volume IV, Number 4 (December 1991), pp 17-23.
 
-[GUILE]
-     Tom Lord.  The Guile Architecture for Ubiquitous Computing.
-     `Usenix Symposium on Tcl/Tk', 1995.
+[SICP]
+     Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+     `Structure and Interpretation of Computer Programs.'  MIT Press,
+     Cambridge, 1985.
+
+[Simply]
+     Brian Harvey and Matthew Wright.  `Simply Scheme: Introducing
+     Computer Science' MIT Press, 1994 ISBN 0-262-08226-8
+
+[SchemePrimer]
+     $B8$;tBg(B(Dai Inukai) `$BF~Lg(BScheme'
+     1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7
 
 [SLIB]
      Todd R. Eigenschink, Dave Love, and Aubrey Jaffer.  SLIB, The
-     Portable Scheme Library.  Version 2c5, Jan 1999.
+     Portable Scheme Library.  Version 2c8, June 2000.
 
      *Note Top: (slib)Top.
 
 [JACAL]
-     Aubrey Jaffer.  JACAL Symbolic Mathematics System.  Version 1a9,
-     Jan 1999.
+     Aubrey Jaffer.  JACAL Symbolic Mathematics System.  Version 1b0,
+     Sep 1999.
 
      *Note Top: (jacal)Top.
 
@@ -297,36 +301,25 @@ 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.
+"scmlit", a "bare-bones" version of SCM sufficient for running `build'.
+`build' 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:
+need to compile SCM without build, there are several ways to proceed:
 
-   * Use SCM on a different platform to run `build.scm' to create a
-     script to build SCM;
+   * Use the build (http://swissnet.ai.mit.edu/~jaffer/buildscm.html)
+     web page to create custom batch scripts for compiling SCM.
+
+   * Use SCM on a different platform to run `build' to create a script
+     to build SCM;
 
-   * Use another implementation of Scheme to run `build.scm' to create a
+   * Use another implementation of Scheme to run `build' 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 the
-     `ANNOUNCE' file in the distribution for details.
-
-   * Use scmconfig (From: bos@scrg.cs.tcd.ie):
-
-     Build and install scripts using GNU "autoconf" are available from
-     `scmconfig4e3.tar.gz' in the distribution directories.  See
-     `README.unix' in `scmconfig4e3.tar.gz' for further instructions.
-
-     *Note:* The last release of scmconfig (4e3) was on March 20, 1996.
-     I am moving it to the OLD subdirectory until someone submits an
-     update.
-
 
 File: scm.info,  Node: SLIB,  Next: Building SCM,  Prev: Making SCM,  Up: Installing SCM
 
@@ -335,22 +328,22 @@ 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
+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:
 
-   * swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz                              |
+   * swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz                              |
 
-   * ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz                                |
+   * ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz                                |
 
-   * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz             |
+   * ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz             |
 
-Unpack SLIB (`tar xzf slib2c7.tar.gz' or `unzip -ao slib2c7.zip') in an       |
+Unpack SLIB (`tar xzf slib2d4.tar.gz' or `unzip -ao slib2d4.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 `Init5d2.scm' is                |
+(this is the same directory as where the file `Init5d6.scm' is                |
 installed).  `require.scm' should have the contents:
 
      (define (library-vicinity) "/usr/local/lib/slib/")
@@ -379,11 +372,12 @@ File: scm.info,  Node: Building SCM,  Next: Installing Dynamic Linking,  Prev: S
 Building SCM
 ============
 
-The file "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.
+The file "build" loads the file "build.scm", which constructs a
+relational database of how to compile and link SCM executables.
+`build.scm' has information for the 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:
 
@@ -397,57 +391,56 @@ File: scm.info,  Node: Invoking Build,  Next: Build Options,  Prev: Building SCM
 Invoking Build
 --------------
 
-The *all* method will also work for MS-DOS and unix.  Use the *all*
-method if you encounter problems with `build.scm'.
+The _all_ method will also work for MS-DOS and unix.  Use the _all_
+method if you encounter problems with `build'.
 
 MS-DOS
      From the SCM source directory, type `build' followed by up to 9
      command line arguments.
 
 unix
-     From the SCM source directory, type `./build.scm' followed by
-     command line arguments.
+     From the SCM source directory, type `./build' followed by command
+     line arguments.
 
-*all*
+_all_
      From the SCM source directory, start `scm' or `scmlit' and type
-     `(load "build.scm")'.  Alternatively, start `scm' or `scmlit' with
-     the command line argument `-ilbuild'.
+     `(load "build")'.  Alternatively, start `scm' or `scmlit' with the
+     command line argument `-ilbuild'.
 
 Invoking build without the `-F' option will build or create a shell
 script with the `arrays', `inexact', and `bignums' options as defaults.
 
-     bash$ ./build.scm
+     bash$ ./build
      -|
-     #!/bin/sh
+     #! /bin/sh
+     # unix (linux) script created by SLIB/batch                              |
+     # ================ Write file with C defines                             |
      rm -f scmflags.h
-     echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h       |
+     echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h                        |
      echo '#define BIGNUMS'>>scmflags.h
      echo '#define FLOATS'>>scmflags.h
      echo '#define ARRAYS'>>scmflags.h
-     gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \
-             eval.c sys.c subr.c unif.c rope.c
-     gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \
-             repl.o scl.o eval.o sys.o subr.o unif.o rope.o -lm -lc
+     # ================ Compile C source files                                |
+     gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
+     # ================ Link C object files                                   |
+     gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
 
 To cross compile for another platform, invoke build with the `-p' or
 `--platform=' option.  This will create a script for the platform named
 in the `-p' or `--platform=' option.
 
-     bash$ ./build.scm -p vms
+     bash$ ./build -o scmlit -p darwin -F lit                                 |
      -|
-     $DELETE scmflags.h
-     $CREATE scmflags.h
-     $DECK
-     #define IMPLINIT "/home/jaffer/scm/Init5d2.scm"                          |
-     #define BIGNUMS
-     #define FLOATS
-     #define ARRAYS
-     $EOD
-     $ cc continue scm findexec script time repl scl eval sys subr unif rope
-     $ macro setjump
-     $ link continue,scm,findexec,script,time,repl,scl,eval,sys,subr,unif,rope,setjump,sys$input/opt
-         -lc,sys$share:vaxcrtl/share
-     $RENAME continue.exe scm.exe
+     #! /bin/sh                                                               |
+     # unix (darwin) script created by SLIB/batch                             |
+     # ================ Write file with C defines                             |
+     rm -f scmflags.h                                                         |
+     echo '#define IMPLINIT "Init5d6.scm"'>>scmflags.h                        |
+     # ================ Compile C source files                                |
+     cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
+     # ================ Link C object files                                   |
+     mv -f scmlit scmlit~                                                     |
+     cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o
 
 
 File: scm.info,  Node: Build Options,  Next: Compiling and Linking Custom Files,  Prev: Invoking Build,  Up: Building SCM
@@ -463,45 +456,48 @@ the SCM command line options.
  - Build Option: --platform=PLATFORM-NAME
      specifies that the compilation should be for a
      computer/operating-system combination called PLATFORM-NAME.
-     *Note:* The case of PLATFORM-NAME is distinguised.  The current
+     _Note:_ The case of PLATFORM-NAME is distinguised.  The current
      PLATFORM-NAMEs are all lower-case.
 
      The platforms defined by table "platform" in `build.scm' are:
 
-     Table: platform
-     name              processor         operating-system  compiler
-     ()                processor-family  operating-system  ()                 |
-     symbol            processor-family  operating-system  symbol
-     symbol            atom              symbol            symbol
-     ================= ================= ================= =================
+     Table: platform                                                          |
+     name              processor         operating-system  compiler           |
+     #f                processor-family  operating-system  #f                 |
+     symbol            processor-family  operating-system  symbol             |
+     symbol            atom              symbol            symbol             |
+     ================= ================= ================= =================  |
      *unknown*         *unknown*         unix              cc                 |
      acorn-unixlib     acorn             *unknown*         cc                 |
      aix               powerpc           aix               cc                 |
-     alpha             alpha             osf1              cc
+     alpha             alpha             osf1              cc                 |
      alpha-elf         alpha             unix              cc                 |
-     alpha-linux       alpha             linux             gcc
+     alpha-linux       alpha             linux             gcc                |
      amiga-aztec       m68000            amiga             cc                 |
      amiga-dice-c      m68000            amiga             dcc                |
-     amiga-gcc         m68000            amiga             gcc
+     amiga-gcc         m68000            amiga             gcc                |
      amiga-sas         m68000            amiga             lc                 |
-     atari-st-gcc      m68000            atari.st          gcc
+     atari-st-gcc      m68000            atari.st          gcc                |
      atari-st-turbo-c  m68000            atari.st          tcc                |
      borland-c         8086              ms-dos            bcc                |
-     cygwin32          i386              unix              gcc
-     djgpp             i386              ms-dos            gcc
-     freebsd           i386              unix              cc
-     gcc               *unknown*         unix              gcc
+     cygwin32          i386              unix              gcc                |
+     darwin            powerpc           unix              cc                 |
+     djgpp             i386              ms-dos            gcc                |
+     freebsd           i386              unix              cc                 |
+     gcc               *unknown*         unix              gcc                |
      highc             i386              ms-dos            hc386              |
      hp-ux             hp-risc           hp-ux             cc                 |
-     irix              mips              irix              gcc
-     linux             i386              linux             gcc
-     linux-aout        i386              linux             gcc
+     irix              mips              irix              gcc                |
+     linux             i386              linux             gcc                |
+     linux-aout        i386              linux             gcc                |
      microsoft-c       8086              ms-dos            cl                 |
      microsoft-c-nt    i386              ms-dos            cl                 |
      microsoft-quick-c 8086              ms-dos            qcl                |
      ms-dos            8086              ms-dos            cc                 |
+     openbsd           *unknown*         unix              gcc                |
      os/2-cset         i386              os/2              icc                |
-     os/2-emx          i386              os/2              gcc
+     os/2-emx          i386              os/2              gcc                |
+     plan9-8           i386              plan9             8c                 |
      sunos             sparc             sunos             cc                 |
      svr4              *unknown*         unix              cc                 |
      svr4-gcc-sun-ld   sparc             sunos             gcc                |
@@ -509,7 +505,7 @@ the SCM command line options.
      unicos            cray              unicos            cc                 |
      unix              *unknown*         unix              cc                 |
      vms               vax               vms               cc                 |
-     vms-gcc           vax               vms               gcc
+     vms-gcc           vax               vms               gcc                |
      watcom-9.0        i386              ms-dos            wcc386p            |
 
  - Build Option: -o FILENAME
@@ -543,9 +539,9 @@ the SCM command line options.
  - Build Option: -s PATHNAME
  - Build Option: --scheme-initial=PATHNAME
      specifies that PATHNAME should be the default location of the SCM
-     initialization file `Init5d2.scm'.  SCM tries several likely             |
+     initialization file `Init5d6.scm'.  SCM tries several likely             |
      locations before resorting to PATHNAME (*note File-System
-     Habitat::.).  If not specified, the current directory (where build
+     Habitat::).  If not specified, the current directory (where build
      is building) is used.
 
  - Build Option: -c PATHNAME ...
@@ -590,7 +586,7 @@ the SCM command line options.
 
         * vms
 
-        * amigados
+        * amigaos (was amigados)                                              |
 
         * system
 
@@ -611,23 +607,23 @@ the SCM command line options.
      specifies to build the given features into the executable.  The
      defined features are:
 
-    "array"                                                                   |
-          Alias for ARRAYS                                                    |
-                                                                              |
-    "array-for-each"                                                          |
-          array-map! and array-for-each (arrays must also be featured).       |
-                                                                              |
-    "arrays"                                                                  |
-          Use if you want arrays, uniform-arrays and uniform-vectors.         |
-                                                                              |
-    "bignums"                                                                 |
-          Large precision integers.                                           |
-                                                                              |
-    "careful-interrupt-masking"                                               |
-          Define this for extra checking of interrupt masking and some        |
-          simple checks for proper use of malloc and free.  This is for       |
-          debugging C code in `sys.c', `eval.c', `repl.c' and makes the       |
-          interpreter several times slower than usual.                        |
+    "array"
+          Alias for ARRAYS
+
+    "array-for-each"
+          array-map! and array-for-each (arrays must also be featured).
+
+    "arrays"
+          Use if you want arrays, uniform-arrays and uniform-vectors.
+
+    "bignums"
+          Large precision integers.
+
+    "careful-interrupt-masking"
+          Define this for extra checking of interrupt masking and some
+          simple checks for proper use of malloc and free.  This is for
+          debugging C code in `sys.c', `eval.c', `repl.c' and makes the
+          interpreter several times slower than usual.
 
     "cautious"
           Normally, the number of arguments arguments to interpreted
@@ -638,125 +634,125 @@ the SCM command line options.
           always check the number of arguments to interpreted closures
           define feature `cautious'.
 
-    "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           |
-          *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.                                                   |
+    "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
+          _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.
 
-    "compiled-closure"                                                        |
-          Use if you want to use compiled closures.                           |
+    "compiled-closure"
+          Use if you want to use compiled closures.
 
-    "curses"                                                                  |
-          For the "curses" screen management package.                         |
+    "curses"
+          For the "curses" screen management package.
 
-    "debug"                                                                   |
-          Turns on the features `cautious',                                   |
-          `careful-interrupt-masking', and `stack-limit'; uses `-g'           |
-          flags for debugging SCM source code.                                |
+    "debug"
+          Turns on the features `cautious',
+          `careful-interrupt-masking', and `stack-limit'; uses `-g'
+          flags for debugging SCM source code.
 
-    "dump"                                                                    |
-          Convert a running scheme program into an executable file.           |
+    "dump"
+          Convert a running scheme program into an executable file.
 
-    "dynamic-linking"                                                         |
-          Be able to load compiled files while running.                       |
+    "dynamic-linking"
+          Be able to load compiled files while running.
 
-    "edit-line"                                                               |
-          interface to the editline or GNU readline library.                  |
+    "edit-line"
+          interface to the editline or GNU readline library.
 
     "engineering-notation"
           Use if you want floats to display in engineering notation
           (exponents always multiples of 3) instead of scientific
           notation.
 
-    "generalized-c-arguments"                                                 |
-          `make_gsubr' for arbitrary (< 11) arguments to C functions.         |
+    "generalized-c-arguments"
+          `make_gsubr' for arbitrary (< 11) arguments to C functions.
 
-    "i/o-extensions"                                                          |
-          Commonly available I/O extensions: "exec", line I/O, file           |
-          positioning, file delete and rename, and directory functions.       |
+    "i/o-extensions"
+          Commonly available I/O extensions: "exec", line I/O, file
+          positioning, file delete and rename, and directory functions.
 
-    "inexact"                                                                 |
-          Use if you want floating point numbers.                             |
+    "inexact"
+          Use if you want floating point numbers.
 
-    "lit"                                                                     |
-          Lightweight - no features                                           |
+    "lit"
+          Lightweight - no features
 
-    "macro"                                                                   |
-          C level support for hygienic and referentially transparent          |
-          macros (syntax-rules macros).                                       |
-                                                                              |
-    "mysql"                                                                   |
-          Client connections to the mysql databases.                          |
-                                                                              |
-    "no-heap-shrink"                                                          |
-          Use if you want segments of unused heap to not be freed up          |
-          after garbage collection.  This may increase time in GC for         |
-          *very* large working sets.                                          |
-                                                                              |
-    "none"                                                                    |
-          No features                                                         |
-                                                                              |
-    "posix"                                                                   |
-          Posix functions available on all "Unix-like" systems.  fork         |
-          and process functions, user and group IDs, file permissions,        |
-          and "link".                                                         |
-                                                                              |
-    "reckless"                                                                |
-          If your scheme code runs without any errors you can disable         |
-          almost all error checking by compiling all files with               |
-          `reckless'.                                                         |
+    "macro"
+          C level support for hygienic and referentially transparent
+          macros (syntax-rules macros).
+
+    "mysql"
+          Client connections to the mysql databases.
+
+    "no-heap-shrink"
+          Use if you want segments of unused heap to not be freed up
+          after garbage collection.  This may increase time in GC for
+          *very* large working sets.
+
+    "none"
+          No features
+
+    "posix"
+          Posix functions available on all "Unix-like" systems.  fork
+          and process functions, user and group IDs, file permissions,
+          and "link".
+
+    "reckless"
+          If your scheme code runs without any errors you can disable
+          almost all error checking by compiling all files with
+          `reckless'.
 
     "record"
           The Record package provides a facility for user to define
           their own record data types.  See SLIB for documentation.
 
-    "regex"                                                                   |
-          String regular expression matching.                                 |
+    "regex"
+          String regular expression matching.
 
-    "rev2-procedures"                                                         |
-          These procedures were specified in the `Revised^2 Report on         |
-          Scheme' but not in `R4RS'.                                          |
+    "rev2-procedures"
+          These procedures were specified in the `Revised^2 Report on
+          Scheme' but not in `R4RS'.
 
-    "sicp"                                                                    |
-          Use if you want to run code from:                                   |
+    "sicp"
+          Use if you want to run code from:
 
-          Harold Abelson and Gerald Jay Sussman with Julie Sussman.           |
-          `Structure and Interpretation of Computer Programs.'  The MIT       |
-          Press, Cambridge, Massachusetts, USA, 1985.                         |
+          Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+          `Structure and Interpretation of Computer Programs.'  The MIT
+          Press, Cambridge, Massachusetts, USA, 1985.
 
-          Differences from R5RS are:                                          |
-             * (eq? '() '#f)                                                  |
+          Differences from R5RS are:
+             * (eq? '() '#f)
 
-             * (define a 25) returns the symbol a.                            |
+             * (define a 25) returns the symbol a.
 
-             * (set! a 36) returns 36.                                        |
+             * (set! a 36) returns 36.
 
-    "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.                                                            |
+    "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.
 
     "socket"
           BSD "socket" interface.
 
-    "stack-limit"                                                             |
-          Use to enable checking for stack overflow.  Define value of         |
-          the C preprocessor variable 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.                                 |
-                                                                              |
-    "tick-interrupts"                                                         |
-          Use if you want the ticks and ticks-interrupt functions.            |
-                                                                              |
-    "turtlegr"                                                                |
-          "Turtle" graphics calls for both Borland-C and X11 from             |
-          sjm@ee.tut.fi.                                                      |
+    "stack-limit"
+          Use to enable checking for stack overflow.  Define value of
+          the C preprocessor variable 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.
+
+    "tick-interrupts"
+          Use if you want the ticks and ticks-interrupt functions.
+
+    "turtlegr"
+          "Turtle" graphics calls for both Borland-C and X11 from
+          sjm@ee.tut.fi.
 
     "unix"
           Those unix features which have not made it into the Posix
@@ -765,11 +761,11 @@ the SCM command line options.
     "windows"
           Microsoft Windows executable.
 
-    "x"                                                                       |
-          Alias for Xlib feature.                                             |
+    "x"
+          Alias for Xlib feature.
 
-    "xlib"                                                                    |
-          Interface to Xlib graphics routines.                                |
+    "xlib"
+          Interface to Xlib graphics routines.
 
 
 
@@ -785,16 +781,16 @@ A correspondent asks:
      functions we want access to).  Would this involve changing
      build.scm or the Makefile or both?
 
-(*note Changing Scm::. has instructions describing the C code format).
+(*note Changing Scm:: has instructions describing the C code format).
 Suppose a C file "foo.c" has functions you wish to add to SCM.  To
 compile and link your file at compile time, use the `-c' and `-i'
 options to build:
 
      bash$ build -c foo.c -i init_foo
      -|
-     #!/bin/sh
+     #! /bin/sh
      rm -f scmflags.h
-     echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h       |
+     echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h       |
      echo '#define COMPILED_INITS init_foo();'>>scmflags.h
      echo '#define BIGNUMS'>>scmflags.h
      echo '#define FLOATS'>>scmflags.h
@@ -808,9 +804,9 @@ To make a dynamically loadable object file use the `-t dll' option:
 
      bash$ build -t dll -c foo.c
      -|
-     #!/bin/sh
+     #! /bin/sh
      rm -f scmflags.h
-     echo '#define IMPLINIT "/home/jaffer/scm/Init5d2.scm"'>>scmflags.h       |
+     echo '#define IMPLINIT "/home/jaffer/scm/Init5d6.scm"'>>scmflags.h       |
      echo '#define BIGNUMS'>>scmflags.h
      echo '#define FLOATS'>>scmflags.h
      echo '#define ARRAYS'>>scmflags.h
@@ -874,7 +870,7 @@ The SLIB module "catalog" can be extended to define other
 `mkimpcat.scm'.  Within `mkimpcat.scm', the following procedures are
 defined.
 
- - Function: add-link FEATURE OBJECT-FILE LIB1 ...
+ - Function: add-link feature object-file lib1 ...
      FEATURE should be a symbol.  OBJECT-FILE should be a string naming
      a file containing compiled "object-code".  Each LIBn argument
      should be either a string naming a library file or `#f'.
@@ -895,7 +891,7 @@ defined.
                                          link:able-suffix))
 
 
- - Function: add-alias ALIAS FEATURE
+ - Function: add-alias alias feature
      ALIAS and FEATURE are symbols.  The procedure `add-alias'
      registers ALIAS as an alias for FEATURE.  An unspecified value is
      returned.
@@ -903,7 +899,7 @@ defined.
      `add-alias' causes `(require 'ALIAS)' to behave like `(require
      'FEATURE)'.
 
- - Function: add-source FEATURE FILENAME
+ - Function: add-source feature filename
      FEATURE is a symbol.  FILENAME is a string naming a file
      containing Scheme source code.  The procedure `add-source'
      registers FEATURE so that the first time `require' is called with
@@ -920,7 +916,7 @@ Saving Images
 =============
 
 In SCM, the ability to save running program images is called "dump"
-(*note Dump::.).  In order to make `dump' available to SCM, build with
+(*note Dump::).  In order to make `dump' available to SCM, build with
 feature `dump'.  `dump'ed executables are compatible with dynamic
 linking.
 
@@ -948,7 +944,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
      -------         ----------
      ARM_ULIB        Huw Rogers free unix library for acorn archimedes
      AZTEC_C         Aztec_C 5.2a
-     __CYGWIN__      Cygwin                                                   |
+     __CYGWIN__      Cygwin
      _DCC            Dice C on AMIGA
      __GNUC__        Gnu CC (and DJGPP)
      __EMX__         Gnu C port (gcc/emx 0.8e) to OS/2 2.0
@@ -966,8 +962,9 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
      __ZTC__         Zortech C
      
      _AIX            AIX operating system
+     __APPLE__       Apple Darwin                                             |
      AMIGA           SAS/C 5.10 or Dice C on AMIGA
-     __amigados__    Gnu CC on AMIGA
+     __amigaos__     Gnu CC on AMIGA                                          |
      atarist         ATARI-ST under Gnu CC
      __FreeBSD__     FreeBSD
      GNUDOS          DJGPP (obsolete in version 1.08)
@@ -976,11 +973,12 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
      linux           Linux
      macintosh       Macintosh (THINK_C and __MWERKS__ define)
      MCH_AMIGA       Aztec_c 5.2a on AMIGA
+     __MACH__        Apple Darwin                                             |
      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.
-     __svr4__        SunOS
+     __SVR4          SunOS
      THINK_C         developement environment for the Macintosh
      ultrix          VAX with ULTRIX operating system.
      unix            most Unix and similar systems and DJGPP (!?)
@@ -991,7 +989,7 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
      vax11c          VAX C compiler
      VAX11           VAX C compiler
      _Windows        Borland C 3.1 compiling for Windows
-     _WIN32          MS VisualC++ 4.2 and Cygwin (Win32 API)                  |
+     _WIN32          MS VisualC++ 4.2 and Cygwin (Win32 API)
      vms             (and VMS) VAX-11 C under VMS.
      
      __alpha         DEC Alpha processor
@@ -1000,6 +998,8 @@ lines or add a `#define FLAG' line to `scmfig.h' or the beginning of
      __i386__        DJGPP
      i386            DJGPP
      MULTIMAX        Encore computer
+     ppc             PowerPC                                                  |
+     __ppc__         PowerPC                                                  |
      pyr             Pyramid 9810 processor
      __sgi__         Silicon Graphics Inc.
      sparc           SPARC processor
@@ -1013,32 +1013,32 @@ File: scm.info,  Node: Problems Compiling,  Next: Problems Linking,  Prev: Autom
 Problems Compiling
 ==================
 
-FILE    PROBLEM / MESSAGE                HOW TO FIX                       
-*.c     include file not found.          Correct the status of            
-                                         STDC_HEADERS in scmfig.h.        
-                                         fix #include statement or add    
-                                         #define for system type to       
-                                         scmfig.h.                        
-*.c     Function should return a value.  Ignore.                          
-        Parameter is never used.                                          
-        Condition is always false.                                        
-        Unreachable code in function.                                     
-scm.c   assignment between incompatible  Change SIGRETTYPE in scm.c.      
-        types.                                                            
-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.                 
-subr.c  Possibly incorrect assignment    Ignore.                          
-        in function lgcd.                                                 
-sys.c   statement not reached.           Ignore.                          
-        constant in conditional                                           
-        expression.                                                       
-sys.c   undeclared, outside of           #undef STDC_HEADERS in scmfig.h. 
-        functions.                                                        
-scl.c   syntax error.                    #define SYSTNAME to your system  
-                                         type in scl.c (softtype).        
+FILE    PROBLEM / MESSAGE                HOW TO FIX
+*.c     include file not found.          Correct the status of
+                                         STDC_HEADERS in scmfig.h.
+                                         fix #include statement or add
+                                         #define for system type to
+                                         scmfig.h.
+*.c     Function should return a value.  Ignore.
+        Parameter is never used.         
+        Condition is always false.       
+        Unreachable code in function.    
+scm.c   assignment between incompatible  Change SIGRETTYPE in scm.c.
+        types.                           
+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.
+subr.c  Possibly incorrect assignment    Ignore.
+        in function lgcd.                
+sys.c   statement not reached.           Ignore.
+        constant in conditional          
+        expression.                      
+sys.c   undeclared, outside of           #undef STDC_HEADERS in scmfig.h.
+        functions.                       
+scl.c   syntax error.                    #define SYSTNAME to your system
+                                         type in scl.c (softtype).
 
 
 File: scm.info,  Node: Problems Linking,  Next: Problems Running,  Prev: Problems Compiling,  Up: Installing SCM
@@ -1046,8 +1046,8 @@ File: scm.info,  Node: Problems Linking,  Next: Problems Running,  Prev: Problem
 Problems Linking
 ================
 
-PROBLEM                              HOW TO FIX                           
-_sin etc. missing.                   Uncomment LIBS in makefile.          
+PROBLEM                              HOW TO FIX
+_sin etc. missing.                   Uncomment LIBS in makefile.
 
 
 File: scm.info,  Node: Problems Running,  Next: Testing,  Prev: Problems Linking,  Up: Installing SCM
@@ -1055,38 +1055,38 @@ File: scm.info,  Node: Problems Running,  Next: Testing,  Prev: Problems Linking
 Problems Running
 ================
 
-PROBLEM                              HOW TO FIX                           
-Opening message and then machine     Change memory model option to C      
-crashes.                             compiler (or makefile).              
-                                     Make sure sizet definition is        
-                                     correct in scmfig.h.                 
-                                     Reduce the size of HEAP_SEG_SIZE in  
-                                     setjump.h.                           
-Input hangs.                         #define NOSETBUF                     
-ERROR: heap: need larger initial.    Increase initial heap allocation     
-                                     using -a<kb> or INIT_HEAP_SIZE.      
-ERROR: Could not allocate.           Check sizet definition.              
-                                     Use 32 bit compiler mode.            
-                                     Don't try to run as subproccess.     
-remove <FLAG> in scmfig.h and        Do so and recompile files.           
-recompile scm.                                                            
-add <FLAG> in scmfig.h and                                                
-recompile scm.                                                            
-ERROR: Init5d2.scm not found.        Assign correct IMPLINIT in makefile      |
-                                     or scmfig.h.                         
-                                     Define environment variable          
-                                     SCM_INIT_PATH to be the full         
-                                     pathname of Init5d2.scm.                 |
-WARNING: require.scm not found.      Define environment variable          
-                                     SCHEME_LIBRARY_PATH to be the full   
-                                     pathname of the scheme library       
-                                     [SLIB].                              
-                                     Change library-vicinity in           
-                                     Init5d2.scm to point to library or       |
-                                     remove.                              
-                                     Make sure the value of               
-                                     (library-vicinity) has a trailing    
-                                     file separator (like / or \).        
+PROBLEM                              HOW TO FIX
+Opening message and then machine     Change memory model option to C
+crashes.                             compiler (or makefile).
+                                     Make sure sizet definition is
+                                     correct in scmfig.h.
+                                     Reduce the size of HEAP_SEG_SIZE in
+                                     setjump.h.
+Input hangs.                         #define NOSETBUF
+ERROR: heap: need larger initial.    Increase initial heap allocation
+                                     using -a<kb> or INIT_HEAP_SIZE.
+ERROR: Could not allocate.           Check sizet definition.
+                                     Use 32 bit compiler mode.
+                                     Don't try to run as subproccess.
+remove <FLAG> in scmfig.h and        Do so and recompile files.
+recompile scm.                       
+add <FLAG> in scmfig.h and           
+recompile scm.                       
+ERROR: Init5d6.scm not found.        Assign correct IMPLINIT in makefile      |
+                                     or scmfig.h.
+                                     Define environment variable
+                                     SCM_INIT_PATH to be the full
+                                     pathname of Init5d6.scm.                 |
+WARNING: require.scm not found.      Define environment variable
+                                     SCHEME_LIBRARY_PATH to be the full
+                                     pathname of the scheme library
+                                     [SLIB].
+                                     Change library-vicinity in
+                                     Init5d6.scm to point to library or       |
+                                     remove.
+                                     Make sure the value of
+                                     (library-vicinity) has a trailing
+                                     file separator (like / or \).
 
 
 File: scm.info,  Node: Testing,  Next: Reporting Problems,  Prev: Problems Running,  Up: Installing SCM
@@ -1114,13 +1114,13 @@ of pi.
      > (load "pi")
      ;loading "pi"
      ;done loading "pi.scm"
-     ;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other
+     ;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B 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
+     ;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other        |
      #<unspecified>
 
 Loading `bench.scm' will compute and display performance statistics of
@@ -1128,34 +1128,34 @@ SCM running `pi.scm'.  `make bench' or `make benchlit' appends the
 performance report to the file `BenchLog', facilitating tracking
 effects of changes to SCM on performance.
 
-PROBLEM                              HOW TO FIX                           
-Runs some and then machine crashes.  See above under machine crashes.     
-Runs some and then ERROR: ...        Remove optimization option to C      
-(after a GC has happened).           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_... in  
-output files.                        `Init5d2.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 in        
-                                     `scmfig.h'.                          
-VAX: botched longjmp.                                                     
+PROBLEM                              HOW TO FIX
+Runs some and then machine crashes.  See above under machine crashes.
+Runs some and then ERROR: ...        Remove optimization option to C
+(after a GC has happened).           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_... in
+output files.                        `Init5d6.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 in
+                                     `scmfig.h'.
+VAX: botched longjmp.                
 
 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
+     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.
 
@@ -1167,8 +1167,8 @@ Reporting Problems
 
 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 `jaffer @ ai.mit.edu'.  The bug report should
-include:
+can send a bug report to `jaffer @ alum.mit.edu'.  The bug report             |
+should include:                                                               |
 
   1. The version of SCM (printed when SCM is invoked with no arguments).
 
@@ -1211,10 +1211,11 @@ File: scm.info,  Node: Invoking SCM,  Next: SCM Options,  Prev: Operational Feat
 Invoking SCM
 ============
 
-scm  [-a kbytes] [-ibvqmu] [-p number]
-     [-c expression] [-e expression] [-f filename]
-     [-l filename] [-r feature] [-- | - | -s]
-     [filename] [arguments ...]
+ scm  [-a kbytes] [-muvbiq] [-version] [-help]
+     [[-]-no-init-file] [-p int] [-r feature] [-h feature]
+     [-d filename] [-f filename] [-l filename]
+     [-c expression] [-e expression] [-o dumpname]
+     [-- | - | -s] [filename] [arguments ...]
 
 Upon startup `scm' loads the file specified by by the environment
 variable SCM_INIT_PATH.
@@ -1222,7 +1223,7 @@ variable SCM_INIT_PATH.
 If SCM_INIT_PATH is not defined or if the file it names is not present,
 `scm' tries to find the directory containing the executable file.  If
 it is able to locate the executable, `scm' looks for the initialization
-file (usually `Init5d2.scm') in platform-dependent directories relative       |
+file (usually `Init5d6.scm') in platform-dependent directories relative       |
 to this directory.  See *Note File-System Habitat:: for a blow-by-blow
 description.
 
@@ -1231,12 +1232,12 @@ compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is
 tried.
 
 Unless the option `-no-init-file' or `--no-init-file' occurs in the
-command line, `Init5d2.scm' checks to see if there is file                    |
+command line, `Init5d6.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
+(or in the current directory if HOME is undefined).  If it finds such a
 file it is loaded.
 
-`Init5d2.scm' then looks for command input from one of three sources:         |
+`Init5d6.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.
 
@@ -1253,9 +1254,9 @@ Options
 
 The options are processed in the order specified on the command line.
 
- - Command Option: -a KB
-     specifies that `scm' should allocate an initial heapsize of KB
-     kilobytes. This option, if present, must be the first on the
+ - Command Option: -a k                                                       |
+     specifies that `scm' should allocate an initial heapsize of K            |
+     kilobytes.  This option, if present, must be the first on the
      command line.  If not specified, the default is `INIT_HEAP_SIZE'
      in source file `setjump.h' which the distribution sets at
      `25000*sizeof(cell)'.
@@ -1264,28 +1265,51 @@ The options are processed in the order specified on the command line.
  - Command Option: --no-init-file
      Inhibits the loading of `ScmInit.scm' as described above.
 
- - Command Option: -e EXPRESSION
- - Command Option: -c EXPRESSION
-     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 quotes. For instance `"-e(newline)"'.
-
- - Command Option: -r FEATURE
-     requires FEATURE. This will load a file from [SLIB] if that
-     FEATURE is not already supported. If FEATURE is 2, 3, 4, or 5
-     `scm' will require the features neccessary to support [R2RS],
-     [R3RS], [R4RS], or [R5RS], respectively.
-
- - Command Option: -l FILENAME
- - Command Option: -f FILENAME
-     loads FILENAME. `Scm' will load the first (unoptioned) file named
+ - Command Option: --help
+     prints usage information and URI; then exit.
+
+ - Command Option: --version
+     prints version information and exit.
+
+ - Command Option: -r feature
+     requires FEATURE.  This will load a file from [SLIB] if that
+     FEATURE is not already provided.  If FEATURE is 2, 2rs, r2rs, 3,         |
+     3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; `scm' will require the         |
+     features neccessary to support [R2RS], [R3RS], [R4RS], or [R5RS],        |
+     respectively.                                                            |
+
+ - Command Option: -h feature
+     provides FEATURE.
+
+ - Command Option: -l filename
+ - Command Option: -f filename
+     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.
 
- - Command Option: -p LEVEL
-     sets the prolixity (verboseness) to LEVEL. This is the same as the
-     `scm' command (verobse LEVEL).
+ - Command Option: -d filename
+     Loads SLIB `databases' feature and opens FILENAME as a database.         |
+
+ - Command Option: -e expression
+ - Command Option: -c expression
+     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 quotes.  For instance `"-e(newline)"'.
+
+ - Command Option: -o dumpname
+     saves the current SCM session as the executable program `dumpname'.
+     This option works only in SCM builds supporting `dump' (*note
+     Dump::).
+
+     If options appear on the command line after `-o DUMPNAME', 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.
+
+ - Command Option: -p level
+     sets the prolixity (verboseness) to LEVEL.  This is the same as
+     the `scm' command (verobse LEVEL).
 
  - Command Option: -v
      (verbose mode) specifies that `scm' will print prompts, evaluation
@@ -1298,7 +1322,7 @@ The options are processed in the order specified on the command line.
 
  - Command Option: -m
      specifies that subsequent loads, evaluations, and user
-     interactions will be with syntax-rules macro capability. To use a
+     interactions will be with syntax-rules macro capability.  To use a
      specific syntax-rules macro implementation from [SLIB] (instead of
      [SLIB]'s default) put `-r' MACROPACKAGE before `-m' on the command
      line.
@@ -1306,21 +1330,21 @@ The options are processed in the order specified on the command line.
  - Command Option: -u
      specifies that subsequent loads, evaluations, and user
      interactions will be without syntax-rules macro capability.
-     syntax-rules macro capability can be restored by a subsequent `-m'
+     Syntax-rules macro capability can be restored by a subsequent `-m'
      on the command line or from Scheme code.
 
  - Command Option: -i
-     specifies that `scm' should run interactively. That means that
+     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.
+     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.
 
  - Command Option: -b
-     specifies that `scm' should run non-interactively. That means that
+     specifies that `scm' should run non-interactively.  That means that
      `scm' will terminate after processing the command line or if there
      are errors.
 
@@ -1332,25 +1356,6 @@ The options are processed in the order specified on the command line.
  - Command Option: --
      specifies that there are no more options on the command line.
 
- - Command Option: -d FILENAME
-     loads SLIB database-utilities and opens FILENAME as a database.
-
- - Command Option: -o FILENAME
-     saves the current SCM session as the executable program `filename'.
-     This option works only in SCM builds supporting `dump' (*note
-     Dump::.).
-
-     If options appear on the command line after `-o 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.
-
- - Command Option: --help
-     prints usage information and URL; then exit.
-
- - Command Option: --version
-     prints version information and exit.
-
 
 File: scm.info,  Node: Invocation Examples,  Next: SCM Variables,  Prev: SCM Options,  Up: Operational Features
 
@@ -1391,13 +1396,13 @@ Environment Variables
 
  - Environment Variable: SCM_INIT_PATH
      is the pathname where `scm' will look for its initialization code.
-     The default is the file `Init5d2.scm' in the source directory.           |
+     The default is the file `Init5d6.scm' in the source directory.           |
 
  - Environment Variable: SCHEME_LIBRARY_PATH
      is the [SLIB] Scheme library directory.
 
  - Environment Variable: HOME
-     is the directory where `Init5d2.scm' will look for the user              |
+     is the directory where `Init5d6.scm' will look for the user              |
      initialization file `ScmInit.scm'.
 
  - Environment Variable: EDITOR
@@ -1408,20 +1413,20 @@ Scheme Variables
 ================
 
  - Variable: *argv*
-     contains the list of arguments to the program. `*argv*' can change
-     during argument processing. This list is suitable for use as an
+     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'.
 
- - Variable: *R4RS-macro*
+ - Variable: *syntax-rules*                                                   |
      controls whether loading and interaction support syntax-rules
-     macros. Define this in `ScmInit.scm' or files specified on the
-     command line. This can be overridden by subsequent `-m' and `-u'
+     macros.  Define this in `ScmInit.scm' or files specified on the
+     command line.  This can be overridden by subsequent `-m' and `-u'
      options.
 
  - Variable: *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.
+     line.  This can be overridden by subsequent `-i' and `-b' options.
 
 
 File: scm.info,  Node: SCM Session,  Next: Editing Scheme Code,  Prev: SCM Variables,  Up: Operational Features
@@ -1440,13 +1445,18 @@ SCM Session
      form and resumes the top level read-eval-print loop.
 
  - Function: quit
- - Function: quit N
+ - Function: quit n
  - Function: exit
- - Function: exit N
+ - Function: exit n
      Aliases for `exit' (*note exit: (slib)System.).  On many systems,
      SCM can also tail-call another program.  *Note execp:
      I/O-Extensions.
 
+ - Callback procedure: boot-tail dumped?                                      |
+     `boot-tail' is called by `scm_top_level' just before entering            |
+     interactive top-level.  If `boot-tail' calls `quit', then                |
+     interactive top-level is not entered.                                    |
+                                                                              |
  - Function: program-arguments
      Returns a list of strings of the arguments scm was called with.
 
@@ -1463,11 +1473,11 @@ File: scm.info,  Node: Editing Scheme Code,  Next: Debugging Scheme Code,  Prev:
 Editing Scheme Code
 ===================
 
- - Function: ed ARG1 ...
+ - Function: ed arg1 ...
      The value of the environment variable `EDITOR' (or just `ed' if it
      isn't defined) is invoked as a command with arguments ARG1 ....
 
- - Function: ed FILENAME
+ - Function: ed filename
      If SCM is compiled under VMS `ed' will invoke the editor with a
      single the single argument FILENAME.
 
@@ -1476,11 +1486,11 @@ Gnu Emacs:
      files ending in .scm are automatically put into scheme-mode.
      EMACS for MS-DOS and MS-Windows systems is available (free) from:
 
-              `http://simtel.coast.net/SimTel/gnu/demacs.html'
+              <http://simtel.coast.net/SimTel/gnu/demacs.html>
 
      If your Emacs can run a process in a buffer you can use the Emacs
-command `M-x run-scheme' with SCM.  Otherwise, use the emacs command
-`M-x suspend-emacs'; or see "other systems" below.
+     command `M-x run-scheme' with SCM.  Otherwise, use the emacs
+     command `M-x suspend-emacs'; or see "other systems" below.
 
 Epsilon (MS-DOS):
      There is lisp (and scheme) mode available by use of the package
@@ -1499,7 +1509,7 @@ Epsilon (MS-DOS):
 
 other systems:
      Define the environment variable `EDITOR' to be the name of the
-     editing program you use.  The SCM procedure `(ed arg1 ...)'  will
+     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:
 
@@ -1515,7 +1525,7 @@ Debugging Scheme Code
 =====================
 
 The `cautious' and `stack-limit' options of `build' (*note Build
-Options::.) support debugging in Scheme.
+Options::) support debugging in Scheme.
 
 "CAUTIOUS"
      If SCM is built with the `CAUTIOUS' flag, then when an error
@@ -1548,7 +1558,7 @@ Options::.) support debugging in Scheme.
 There are several SLIB macros which so useful that SCM automatically
 loads the appropriate module from SLIB if they are invoked.
 
- - Macro: trace PROC1 ...
+ - Macro: trace proc1 ...
      Traces the top-level named procedures given as arguments.
 
  - Macro: trace
@@ -1556,7 +1566,7 @@ loads the appropriate module from SLIB if they are invoked.
      identifiers are traced (even if those identifiers have been
      redefined) and returns a list of the traced identifiers.
 
- - Macro: untrace PROC1 ...
+ - Macro: untrace proc1 ...
      Turns tracing off for its arguments.
 
  - Macro: untrace
@@ -1565,7 +1575,7 @@ loads the appropriate module from SLIB if they are invoked.
 
 The routines I use most frequently for debugging are:
 
- - Procedure: print ARG1 ...
+ - Procedure: print arg1 ...
      `Print' writes all its arguments, separated by spaces.  `Print'
      outputs a `newline' at the end and returns the value of the last
      argument.
@@ -1573,7 +1583,7 @@ The routines I use most frequently for debugging are:
      One can just insert `(print '<proc-name>' and `)' around an
      expression in order to see its value as a program operates.
 
- - Syntax: print-args NAME1 ...
+ - Syntax: print-args name1 ...
      Writes NAME1 ... (separated by spaces) and then writes the values
      of the closest lexical bindings enclosing the call to `Print-args'.
 
@@ -1591,8 +1601,8 @@ When `trace' is not sufficient to find program flow problems, SLIB-PSD,
 the Portable Scheme Debugger offers source code debugging from GNU
 Emacs.  PSD runs slowly, so start by instrumenting only a few functions
 at a time.
-     http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz                 |
-     ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz
+     http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz
+     swissnet.ai.mit.edu:/pub/scm/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
 
@@ -1613,7 +1623,7 @@ response code in C.
 
 The following common error and conditions are handled by C code.  Those
 with callback names after them can also be handled by Scheme code
-(*note Interrupts::.).  If the callback identifier is not defined at top
+(*note 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.
 
@@ -1682,13 +1692,13 @@ other error messages which are not treated specially.
      current form, prints a message explaining the error, and resumes
      the top level read-eval-print loop.  The value of ERROBJ is the
      offending object if appropriate.  The builtin procedure `error'
-     does *not* set ERROBJ.
+     does _not_ set ERROBJ.
 
 `errno' and `perror' report ANSI C errors encountered during a call to
 a system or library function.
 
  - Function: errno
- - Function: errno N
+ - Function: errno n
      With no argument returns the current value of the system variable
      `errno'.  When given an argument, `errno' sets the system variable
      `errno' to N and returns the previous value of `errno'.  `(errno
@@ -1696,7 +1706,7 @@ a system or library function.
      `try-load' returns `#f' since this occurs when the file could not
      be opened.
 
- - Function: perror STRING
+ - Function: perror string
      Prints on standard error output the argument STRING, a colon,
      followed by a space, the error message corresponding to the current
      value of `errno' and a newline.  The value returned is unspecified.
@@ -1704,15 +1714,15 @@ a system or library function.
 `warn' and `error' provide a uniform way for Scheme code to signal
 warnings and errors.
 
- - Function: warn ARG1 ARG2 ARG3 ...
+ - Function: warn arg1 arg2 arg3 ...
      Alias for *Note slib:warn: (slib)System.  Outputs an error message
-     containing the arguments.  `warn' is defined in `Init5d2.scm'.           |
+     containing the arguments.  `warn' is defined in `Init5d6.scm'.           |
 
- - Function: error ARG1 ARG2 ARG3 ...
+ - Function: error arg1 arg2 arg3 ...
      Alias for *Note slib:error: (slib)System.  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 `Init5d2.scm'.                                                |
+     defined in `Init5d6.scm'.                                                |
 
 If SCM is built with the `CAUTIOUS' flag, then when an error occurs, a
 "stack trace" of certain pending calls are printed as part of the
@@ -1730,7 +1740,7 @@ with Lisp systems.
  - Function: stack-trace
      Prints information describing the stack of partially evaluated
      expressions.  `stack-trace' returns `#t' if any lines were printed
-     and `#f' otherwise.  See `Init5d2.scm' for an example of the use         |
+     and `#f' otherwise.  See `Init5d6.scm' for an example of the use         |
      of `stack-trace'.
 
 
@@ -1755,7 +1765,7 @@ a convenient aid to locating bugs and untested expressions.
    * The names of identifiers which are not lexiallly bound but defined
      at top-level have #@ prepended.
 
-For instance, `open-input-file' is defined as follows in `Init5d2.scm':       |
+For instance, `open-input-file' is defined as follows in `Init5d6.scm':       |
 
      (define (open-input-file str)
        (or (open-file str OPEN_READ)
@@ -1802,9 +1812,9 @@ Internal State
      The variable *INTERACTIVE* determines whether the SCM session is
      interactive, or should quit after the command line is processed.
      *INTERACTIVE* is controlled directly by the command-line options
-     `-b', `-i', and `-s' (*note Invoking SCM::.).  If none of these
+     `-b', `-i', and `-s' (*note Invoking SCM::).  If none of these
      options are specified, the rules to determine interactivity are
-     more complicated; see `Init5d2.scm' for details.                         |
+     more complicated; see `Init5d6.scm' for details.                         |
 
  - Function: abort
      Resumes the top level Read-Eval-Print loop.
@@ -1815,16 +1825,16 @@ Internal State
      those files have changed, those changes will be reflected in the
      new session.
 
-     *Note:* When running a saved executable (*note Dump::.), `restart'
+     _Note:_ When running a saved executable (*note Dump::), `restart'
      is redefined to be `exec-self'.
 
  - Function: 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 *new* executable
+     since the beginning of the current session, the _new_ executable
      will be invoked.  This differentiates `exec-self' from `restart'.
 
- - Function: verbose N
+ - Function: verbose n
      Controls how much monitoring information is printed.  If N is:
 
     0
@@ -1834,37 +1844,38 @@ Internal State
           a prompt is printed.
 
     >= 2
-          the CPU time is printed after each top level form evaluated.
+          messages bracketing file loading are printed.                       |
 
     >= 3
-          messages about heap growth are printed.
+          the CPU time is printed after each top level form evaluated;        |
+          notifications of heap growth printed.                               |
 
     >= 4
-          garbage collection (*note Garbage Collection::.) messages are
-          printed.
+          a garbage collection summary is printed after each top level        |
+          form evaluated;                                                     |
 
     >= 5
-          a warning will be printed for each top-level symbol which is
-          defined more than one time.
+          a message for each GC (*note Garbage Collection::) is printed;      |
+          warnings issued for top-level symbols redefined.                    |
 
  - Function: gc
      Scans all of SCM objects and reclaims for further use those that
      are no longer accessible.
 
  - Function: room
- - Function: room #T
+ - Function: room #t
      Prints out statistics about SCM's current use of storage.  `(room
      #t)' also gives the hexadecimal heap segment and stack bounds.
 
  - Constant: *scm-version*
-     Contains the version string (e.g. `5d2') of SCM.                         |
+     Contains the version string (e.g. `5d6') of SCM.                         |
 
 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 (*note
-Executable Pathname::.) guesses incorrectly the location of the
+Executable Pathname::) guesses incorrectly the location of the
 currently running executable.  In that case, the correct path can be set
 by calling `execpath' with the pathname.
 
@@ -1873,8 +1884,8 @@ by calling `execpath' with the pathname.
      file whose invocation the currently running session is, or #f if
      the path is not set.
 
- - Function: execpath #F
- - Function: execpath NEWPATH
+ - Function: execpath #f
+ - Function: execpath newpath
      Sets the path to `#f' or NEWPATH, respectively.  The old path is
      returned.
 
@@ -1908,7 +1919,7 @@ file has (different) meanings to SCM and the operating system
      permissions) whose first two characters are `#!'.  The INTERPRETER
      argument must be the pathname of the program to process the rest
      of the file.  The directories named by environment variable `PATH'
-     are *not* searched to find INTERPRETER.
+     are _not_ searched to find INTERPRETER.
 
      When executing a shell-script, the operating system invokes
      INTERPRETER with a single argument encapsulating the rest of the
@@ -1932,7 +1943,7 @@ file has (different) meanings to SCM and the operating system
      `\' substitution; this will only take place if INTERPRETER is a
      SCM or SCSH interpreter.
 
- - Read syntax: #! IGNORED !#
+ - Read syntax: #! ignored !#
      When the first two characters of the file being loaded are `#!' and
      a `\' is present before a newline in the file, all characters up
      to `!#' will be ignored by SCM `read'.
@@ -1940,7 +1951,7 @@ file has (different) meanings to SCM and the operating system
 This combination of interpretatons allows SCM source files to be used as
 POSIX shell-scripts if the first line is:
 
-     #!/usr/local/bin/scm \
+     #! /usr/local/bin/scm \
 
 The following Scheme-Script prints factorial of its argument:
 
@@ -2013,7 +2024,7 @@ following syntax for <PROGRAM>.BAT files.
      Once the INTERPRETER executable path is found, arguments are
      processed in the manner of scheme-shell, with the all the text
      after the `\' taken as part of the meta-argument.  More precisely,
-     `#!'  calls INTERPRETER with any options on the second line of the
+     `#!' calls INTERPRETER with any options on the second line of the
      Scheme-Script up to `!#', the name of the Scheme-Script file, and
      then any of at most 8 arguments given on the command line invoking
      this Scheme-Script.
@@ -2036,7 +2047,7 @@ Scheme-scripts suffer from two drawbacks:
      programs are moved.
 
 The following approach solves these problems at the expense of slower
-startup.  Make `#!/bin/sh' the first line and prepend every subsequent
+startup.  Make `#! /bin/sh' the first line and prepend every subsequent
 line to be executed by the shell with `:;'.  The last line to be
 executed by the shell should contain an "exec" command; `exec'
 tail-calls its argument.
@@ -2096,6 +2107,7 @@ The Language
 * Interrupts::                  and exceptions
 * Process Synchronization::     Because interrupts are preemptive
 * Files and Ports::
+* Line Numbers::                                                              |
 * Soft Ports::                  Emulate I/O devices
 * Syntax Extensions::
 * Low Level Syntactic Hooks::
@@ -2108,7 +2120,7 @@ Standards Compliance
 ====================
 
 Scm conforms to the `IEEE Standard 1178-1990.  IEEE Standard for the
-Scheme Programming Language.'  (*note Bibliography::.), and `Revised(5)
+Scheme Programming Language.'  (*note Bibliography::), and `Revised(5)
 Report on the Algorithmic Language Scheme'.  *Note Top: (r5rs)Top.  All
 the required features of these specifications are supported.  Many of
 the optional features are supported as well.
@@ -2227,7 +2239,7 @@ File: scm.info,  Node: Miscellaneous Procedures,  Next: Time,  Prev: Standards C
 Miscellaneous Procedures
 ========================
 
- - Function: try-load FILENAME
+ - Function: try-load filename
      If the string 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 `#t'.
@@ -2237,37 +2249,39 @@ Miscellaneous Procedures
 
  - Variable: *load-pathname*
      Is set to the pathname given as argument to `load', `try-load',
-     and `dyn:link' (*note Compiling And Linking::.).
-     `*load-pathname*' is used to compute the value of *Note
-     program-vicinity: (slib)Vicinity.
+     and `dyn:link' (*note Compiling And Linking: (hobbit)Compiling And       |
+     Linking.).  `*load-pathname*' is used to compute the value of            |
+     *Note program-vicinity: (slib)Vicinity.                                  |
 
  - Function: line-number
      Returns the current line number of the file currently being loaded.
 
- - Function: port-filename PORT                                               |
-     Returns the filename PORT was opened with.  If PORT is not open to       |
-     a file the result is unspecified.                                        |
-                                                                              |
- - Function: port-line PORT                                                   |
- - Function: port-column PORT                                                 |
-     If PORT is a tracked port, return the current line (column) number,      |
-     otherwise return `#f'.  Line numbers begin with 1, the column            |
-     number is zero if there are no characters on the current line.           |
-                                                                              |
- - Function: eval OBJ
+ - Function: port-filename port
+     Returns the filename PORT was opened with.  If PORT is not open to
+     a file the result is unspecified.
+
+ - Function: port-line port
+ - Function: port-column port
+     If PORT is a tracked port, return the current line (column) number,
+     otherwise return `#f'.  Line and column numbers begin with 1.  The
+     column number applies to the next character to be read; if that
+     character is a newline, then the column number will be one more
+     than the length of the line.
+
+ - Function: eval obj
      Alias for *Note eval: (slib)System.
 
- - Function: eval-string STR
+ - Function: eval-string str
      Returns the result of reading an expression from STR and
      evaluating it.  `eval-string' does not change `*load-pathname*' or
      `line-number'.
 
- - Function: load-string STR
+ - Function: load-string str
      Reads and evaluates all the expressions from STR.  As with `load',
      the value returned is unspecified.  `load-string' does not change
      `*load-pathname*' or `line-number'.
 
- - Function: vector-set-length! OBJECT LENGTH
+ - Function: vector-set-length! object length
      Change the length of string, vector, bit-vector, or uniform-array
      OBJECT to LENGTH.  If this shortens OBJECT then the remaining
      contents are lost.  If it enlarges OBJECT then the contents of the
@@ -2275,23 +2289,23 @@ Miscellaneous Procedures
      It is an error to change the length of literal datums.  The new
      object is returned.
 
- - Function: copy-tree OBJ
- - Function: @copy-tree OBJ
+ - Function: copy-tree obj
+ - Function: @copy-tree obj
      *Note copy-tree: (slib)Tree Operations.  This extends the SLIB
      version by also copying vectors.  Use `@copy-tree' if you depend
      on this feature; `copy-tree' could get redefined.
 
- - Function: acons OBJ1 OBJ2 OBJ3
+ - Function: 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.
 
  - Function: terms
      This command displays the GNU General Public License.
 
- - Function: list-file FILENAME
+ - Function: list-file filename
      Displays the text contents of FILENAME.
 
- - Procedure: print ARG1 ...
+ - Procedure: print arg1 ...
      `Print' writes all its arguments, separated by spaces.  `Print'
      outputs a `newline' at the end and returns the value of the last
      argument.
@@ -2330,7 +2344,7 @@ File: scm.info,  Node: Interrupts,  Next: Process Synchronization,  Prev: Time,
 Interrupts
 ==========
 
- - Function: ticks N
+ - Function: 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.
@@ -2347,15 +2361,15 @@ Interrupts
      should (abort) or some other action which does not return if it
      does not want processing to continue.
 
- - Function: alarm SECS
+ - Function: alarm secs
      Returns the number of seconds remaining till the next alarm
      interrupt.  If SECS is 0, any alarm request is canceled.
      Otherwise an `alarm-interrupt' will be signaled SECS from the
      current time.  ALARM is not supported on all systems.
 
- - Function: milli-alarm MILLISECS INTERVAL
- - Function: virtual-alarm MILLISECS INTERVAL
- - Function: profile-alarm MILLISECS INTERVAL
+ - Function: milli-alarm millisecs interval
+ - Function: virtual-alarm millisecs interval
+ - Function: profile-alarm millisecs interval
      `milli-alarm' is similar to `alarm', except that the first
      argument MILLISECS, and the return value are measured in
      milliseconds rather than seconds.  If the optional argument
@@ -2403,35 +2417,93 @@ Interrupts
      To unestablish a response for an error set the handler symbol to
      `#f'.  For instance, `(set! could-not-open #f)'.
 
+ - Callback procedure: gc-hook ...                                            |
+     Allows a Scheme procedure to be run shortly after each garbage           |
+     collection.  This procedure will not be run recursively.  If it          |
+     runs long enough to cause a garbage collection before returning a        |
+     warning will be printed.                                                 |
+                                                                              |
+ - Function: add-finalizer object finalizer                                   |
+     OBJECT may be any garbage collected object, that is, any object          |
+     other than an immediate integer, character, or special token such        |
+     as `#f' or `#t', *Note Immediates::.  FINALIZER is a thunk, or           |
+     procedure taking no arguments.                                           |
+                                                                              |
+     FINALIZER will be invoked asynchronously exactly once some time          |
+     after OBJECT becomes eligible for garbage collection.  A reference       |
+     to OBJECT in the environment of FINALIZER will not prevent               |
+     finalization, but will delay the reclamation of OBJECT at least          |
+     until the next garbage collection.  A reference to OBJECT in some        |
+     other object's finalizer will necessarily prevent finalization           |
+     until both objects are eligible for garbage collection.                  |
+                                                                              |
+     Finalizers are not run in any predictable order.  All finalizers         |
+     will be run by the time the program ends.                                |
+                                                                              |
+     This facility was based on the paper by Simon Peyton Jones, et al,       |
+     "Stretching the storage manager: weak pointers and stable names in       |
+     Haskell", Proc. 11th International Workshop on the Implementation        |
+     of Functional Languages, The Netherlands, September 7-10 1999,           |
+     Springer-Verlag LNCS.                                                    |
+                                                                              |
+                                                                              |
 
 File: scm.info,  Node: Process Synchronization,  Next: Files and Ports,  Prev: Interrupts,  Up: The Language
 
 Process Synchronization
 =======================
 
- - Function: make-arbiter NAME
+An "exchanger" is a procedure of one argument regulating mutually             |
+exclusive access to a resource.  When a exchanger is called, its current      |
+content is returned, while being replaced by its argument in an atomic        |
+operation.                                                                    |
+                                                                              |
+ - Function: make-exchanger obj                                               |
+     Returns a new exchanger with the argument OBJ as its initial             |
+     content.                                                                 |
+                                                                              |
+          (define queue (make-exchanger (list a)))                            |
+                                                                              |
+     A queue implemented as an exchanger holding a list can be                |
+     protected from reentrant execution thus:                                 |
+                                                                              |
+          (define (pop queue)                                                 |
+            (let ((lst #f))                                                   |
+              (dynamic-wind                                                   |
+                  (lambda () (set! lst (queue #f)))                           |
+                  (lambda () (and lst (not (null? lst))                       |
+                                  (let ((ret (car lst)))                      |
+                                    (set! lst (cdr lst))                      |
+                                    ret)))                                    |
+                  (lambda () (and lst (queue lst))))))                        |
+                                                                              |
+          (pop queue)         => a                                            |
+                                                                              |
+          (pop queue)         => #f                                           |
+                                                                              |
+ - Function: make-arbiter name
      Returns an object of type arbiter and name NAME.  Its state is
      initially unlocked.
 
- - Function: try-arbiter ARBITER
+ - Function: try-arbiter arbiter
      Returns `#t' and locks ARBITER if ARBITER was unlocked.
      Otherwise, returns `#f'.
 
- - Function: release-arbiter ARBITER
+ - Function: release-arbiter arbiter
      Returns `#t' and unlocks ARBITER if ARBITER was locked.
      Otherwise, returns `#f'.
 
 
-File: scm.info,  Node: Files and Ports,  Next: Soft Ports,  Prev: Process Synchronization,  Up: The Language
-
+File: scm.info,  Node: Files and Ports,  Next: Line Numbers,  Prev: Process Synchronization,  Up: The Language
+                                                                              |
 Files and Ports
 ===============
 
 These procedures generalize and extend the standard capabilities in
 *Note Ports: (r5rs)Ports.
 
- - Function: open-file STRING MODES
- - Function: try-open-file STRING MODES
+ - Function: open-file string modes
+ - Function: try-open-file string modes
      Returns a port capable of receiving or delivering characters as
      specified by the MODES string.  If a file cannot be opened `#f' is
      returned.
@@ -2447,34 +2519,44 @@ These procedures generalize and extend the standard capabilities in
      Contain modes strings specifying that a file is to be opened for
      reading, writing, and both reading and writing respectively.
 
- - Function: _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?'        |
-     and `wait-for-input' to work correctly on it.  The initial value of      |
-     `(current-input-port)' is unbuffered if the platform supports it.        |
+     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.            |
                                                                               |
- - Function: _tracked MODESTR                                                 |
+ - Function: _ionbf modestr
+     Returns a version of MODESTR which when `open-file' is called with
+     it as the second argument will return an unbuffered port.  An            |
+     input-port must be unbuffered in order for `char-ready?' and             |
+     `wait-for-input' to work correctly on it.  The initial value of          |
+     `(current-input-port)' is unbuffered if the platform supports it.
+
+ - Function: _tracked modestr
+     Returns a version of MODESTR which when `open-file' is called with
+     it as the second argument will return a tracked port.  A tracked
+     port maintains current line and column numbers, which may be
+     queried with `port-line' and `port-column'.
+
+ - Function: _exclusive modestr                                               |
      Returns a version of MODESTR which when `open-file' is called with       |
-     it as the second argument will return a tracked port.  A tracked         |
-     port maintains current line and column numbers, which may be             |
-     queried with `port_line' and `port_column'.                              |
-
- - Function: close-port PORT
+     it as the second argument will return a port only if the named file      |
+     does not already exist.  This functionality is provided by calling       |
+     `try-create-file' *Note I/O-Extensions::, which is not available         |
+     for all platforms.                                                       |
+                                                                              |
+ - Function: port-closed? port                                                |
+     Returns #t if PORT is closed.                                            |
+                                                                              |
+ - Function: port-type obj                                                    |
+     If OBJ is not a port returns false, otherwise returns a symbol           |
+     describing the port type, for example string or pipe.                    |
+                                                                              |
+ - Function: close-port port
      Closes PORT.  The same as close-input-port and close-output-port.
-
- - Function: open-io-file FILENAME
- - Function: close-io-port PORT
-     These functions are analogous to the standard scheme file
-     functions.  The ports are open to 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.
-
+                                                                              |
  - Function: current-error-port
      Returns the current port to which diagnostic output is directed.
 
- - Function: with-error-to-file STRING THUNK
+ - Function: with-error-to-file string thunk
      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
@@ -2483,15 +2565,23 @@ These procedures generalize and extend the standard capabilities in
      default is restored.  With-error-to-file returns the value yielded
      by THUNK.
 
- - Function: with-input-from-port PORT THUNK
- - Function: with-output-to-port PORT THUNK
- - Function: with-error-to-port PORT THUNK
+ - Function: with-input-from-port port thunk
+ - Function: with-output-to-port port thunk
+ - Function: 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.
 
+ - Function: call-with-outputs thunk proc
+     Calls the THUNK procedure while the current-output-port and
+     current-error-port are directed to string-ports.  If THUNK
+     returns, the PROC procedure is called with the output-string, the
+     error-string, and the value returned by THUNK.  If THUNK does not
+     return a value (perhaps because of error), PROC is called with
+     just the output-string and the error-string as arguments.
+
  - procedure: char-ready?
- - procedure: char-ready? PORT
+ - procedure: char-ready? port
      Returns `#t' if a character is ready on the input PORT and returns
      `#f' otherwise.  If `char-ready?' returns `#t' then the next
      `read-char' operation on the given PORT is guaranteed not to hang.
@@ -2499,44 +2589,103 @@ These procedures generalize and extend the standard capabilities in
      PORT may be omitted, in which case it defaults to the value
      returned by `current-input-port'.
 
-     *Rationale:* `Char-ready?' exists to make it possible for a
+     _Rationale:_ `Char-ready?' exists to make it possible for a
      program to 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 `char-ready?'  cannot be rubbed out.  If
+     been asserted by `char-ready?' cannot be rubbed out.  If
      `char-ready?' were to return `#f' at end of file, a port at end of
      file would be indistinguishable from an interactive port that has
      no ready characters.
 
- - procedure: wait-for-input X
- - procedure: wait-for-input X PORT1 ...
+ - procedure: wait-for-input x
+ - procedure: wait-for-input x port1 ...
      Returns a list those ports PORT1 ... which are `char-ready?'.  If
      none of PORT1 ... become `char-ready?' within the time interval of
      X seconds, then #f is returned.  The PORT1 ... arguments may be
      omitted, in which case they default to the list of the value
      returned by `current-input-port'.
 
- - Function: isatty? PORT
+ - Function: isatty? port
      Returns `#t' if PORT is input or output to a serial non-file
      device.
 
- - Function: freshline PORT                                                   |
-     Outputs a newline to optional argument PORT unless the current           |
-     output column number of PORT is known to be zero, ie output will         |
-     start at the beginning of a new line.  PORT defaults to                  |
-     `current-output-port'. If PORT is not a tracked port `freshline'         |
-     is equivalent to `newline'.                                              |
+ - Function: freshline port
+     Outputs a newline to optional argument PORT unless the current
+     output column number of PORT is known to be zero, ie output will
+     start at the beginning of a new line.  PORT defaults to
+     `current-output-port'.  If PORT is not a tracked port `freshline'
+     is equivalent to `newline'.
+
+ - Function: open-ports                                                       |
+     Returns a list of all currently open ports, excluding string ports,      |
+     see *Note String Ports: (slib)String Ports.  This may be useful          |
+     after a fork *Note Posix Extensions::, or for debugging.  Bear in        |
+     mind that ports that would be closed by gc will be kept open by a        |
+     reference to this list.                                                  |
                                                                               |
 
-File: scm.info,  Node: Soft Ports,  Next: Syntax Extensions,  Prev: Files and Ports,  Up: The Language
-
+File: scm.info,  Node: Line Numbers,  Next: Soft Ports,  Prev: Files and Ports,  Up: The Language
+                                                                              |
+Line Numbers                                                                  |
+============                                                                  |
+                                                                              |
+Scheme code define by load may optionally contain line number                 |
+information.  Currently this information is used only for reporting           |
+expansion time errors, but in the future run-time error messages may          |
+also include line number information.                                         |
+                                                                              |
+ - Function: try-load pathname reader                                         |
+     This is the primitive for loading, PATHNAME is the name of a file        |
+     containing Scheme code, and optional argument READER is a function       |
+     of one argument, a port.  READER should read and return Scheme           |
+     code as list structure.  The default value is `read', which is           |
+     used if READER is not supplied or is false.                              |
+                                                                              |
+Line number objects are disjoint from integers or other Scheme types.         |
+When evaluated or loaded as Scheme code, an s-expression containing a         |
+line-number in the car is equivalent to the cdr of the s-expression.  A       |
+pair consisting of a line-number in the car and a vector in the cdr is        |
+equivalent to the vector.  The meaning of s-expressions with                  |
+line-numbers in other positions is undefined.                                 |
+                                                                              |
+ - Function: read-numbered port                                               |
+     Behaves like `read', except that every s-expression read will be         |
+     replaced with a cons of a line-number object and the sexp actually       |
+     read.  This replacement is done only if PORT is a tracked port See       |
+     *Note Files and Ports::.                                                 |
+                                                                              |
+ - Function: integer->line-number int                                         |
+     Returns a line-number object with value INT.  INT should be an           |
+     exact non-negative integer.                                              |
+                                                                              |
+ - Function: line-number->integer linum                                       |
+     Returns the value of line-number object LINUM as an integer.             |
+                                                                              |
+ - Function: line-number? obj                                                 |
+     Returns true if and only if OBJ is a line-number object.                 |
+                                                                              |
+ - Variable: *load-reader*                                                    |
+ - Variable: *slib-load-reader*                                               |
+     The value of `*load-reader*' should be a value acceptable as the         |
+     second argument to `try-load' (note that #f is acceptable).  This        |
+     value will be used to read code during calls to `scm:load'.  The         |
+     value of `*slib-load-reader*' will similarly be used during calls        |
+     to `slib:load' and `require'.                                            |
+                                                                              |
+     In order to disable all line-numbering, it is sufficient to set!         |
+     `*load-reader*' and `*slib-load-reader*' to #f.                          |
+                                                                              |
+
+File: scm.info,  Node: Soft Ports,  Next: Syntax Extensions,  Prev: Line Numbers,  Up: The Language
+                                                                              |
 Soft Ports
 ==========
 
 A "soft-port" is a port based on a vector of procedures capable of
 accepting or delivering characters.  It allows emulation of I/O ports.
 
- - Function: make-soft-port VECTOR MODES
+ - Function: make-soft-port vector modes
      Returns a port capable of receiving or delivering characters as
      specified by the MODES string (*note open-file: Files and Ports.).
      VECTOR must be a vector of length 6.  Its components are as
@@ -2561,6 +2710,9 @@ accepting or delivering characters.  It allows emulation of I/O ports.
      (r5rs)Input.) it indicates that the port has reached end-of-file.
      For example:
 
+     If it is necessary to explicitly close the port when it is garbage       |
+     collected, (*note add-finalizer: Interrupts.).                           |
+                                                                              |
           (define stdout (current-output-port))
           (define p (make-soft-port
                      (vector
@@ -2579,7 +2731,7 @@ File: scm.info,  Node: Syntax Extensions,  Next: Low Level Syntactic Hooks,  Pre
 Syntax Extensions
 =================
 
- - procedure: procedure-documentation PROC
+ - procedure: procedure-documentation proc
      Returns the documentation string of PROC if it exists, or `#f' if
      not.
 
@@ -2595,18 +2747,18 @@ Syntax Extensions
           => #<unspecified>
           (procedure-documentation square) => "Return the square of X."
 
- - Function: comment STRING1 ...                                              |
-     Appends STRING1 ... to the strings given as arguments to previous        |
-     calls `comment'.                                                         |
-                                                                              |
- - Function: comment                                                          |
-     Returns the (appended) strings given as arguments to previous calls      |
-     `comment' and empties the current string collection.                     |
-                                                                              |
- - Read syntax: #;text-till-end-of-line                                       |
-     Behaves as `(comment "TEXT-TILL-END-OF-LINE")'.                          |
-                                                                              |
- - Read syntax: #. EXPRESSION
+ - Function: comment string1 ...
+     Appends STRING1 ... to the strings given as arguments to previous
+     calls `comment'.
+
+ - Function: comment
+     Returns the (appended) strings given as arguments to previous calls
+     `comment' and empties the current string collection.
+
+ - Read syntax: #;text-till-end-of-line
+     Behaves as `(comment "TEXT-TILL-END-OF-LINE")'.
+
+ - Read syntax: #. expression
      Is read as the object resulting from the evaluation of EXPRESSION.
      This substitution occurs even inside quoted structure.
 
@@ -2617,7 +2769,7 @@ Syntax Extensions
           #.(define foo 9)                        => #<unspecified>
           '(#.foo #.(+ foo foo))                  => (9 18)
 
- - Read syntax: #+ FEATURE FORM
+ - Read syntax: #+ feature form
      If feature is `provided?' (by `*features*') then FORM is read as a
      scheme expression.  If not, then FORM is treated as whitespace.
 
@@ -2627,19 +2779,19 @@ Syntax Extensions
      For more information on `provided?' and `*features*', *Note
      Require: (slib)Require.
 
- - Read syntax: #- FEATURE FORM
+ - Read syntax: #- feature form
      is equivalent to `#+(not feature) expression'.
 
- - Read syntax: #' FORM
+ - Read syntax: #' form
      is equivalent to FORM (for compatibility with common-lisp).
 
- - Read syntax: #| ANY THING |#
+ - Read syntax: #| any thing |#
      Is a balanced comment.  Everything up to the matching `|#' is
      ignored by the `read'.  Nested `#|...|#' can occur inside ANY
      THING.
 
 A similar read syntax "#!" (exclamation rather than vertical bar) is
-supported for Posix shell-scripts (*note Scripting::.).
+supported for Posix shell-scripts (*note Scripting::).
 
  - Read syntax: #\token
      If TOKEN is a sequence of two or more digits, then this syntax is
@@ -2650,31 +2802,31 @@ supported for Posix shell-scripts (*note Scripting::.).
      followed by a character, then a meta character is read.  `c-' and
      `m-' prefixes may be combined.
 
- - Special Form: defined? SYMBOL
+ - Special Form: defined? symbol
      Equivalent to `#t' if SYMBOL is a syntactic keyword (such as `if')
      or a symbol with a value in the top level environment (*note
      Variables and regions: (r5rs)Variables and regions.).  Otherwise
      equivalent to `#f'.
 
- - Special Form: defvar IDENTIFIER INITIAL-VALUE
+ - Special Form: defvar identifier initial-value
      If IDENTIFIER is unbound in the top level environment, then
      IDENTIFIER is `define'd to the result of evaluating the form
      INITIAL-VALUE as if the `defvar' form were instead the form
      `(define identifier initial-value)' .  If IDENTIFIER already has a
-     value, then INITIAL-VALUE is *not* evaluated and IDENTIFIER's
+     value, then INITIAL-VALUE is _not_ evaluated and IDENTIFIER's
      value is not changed.  `defconst' is valid only when used at
      top-level.
 
- - Special Form: defconst IDENTIFIER VALUE
+ - Special Form: defconst identifier value
      If IDENTIFIER is unbound in the top level environment, then
      IDENTIFIER is `define'd to the result of evaluating the form VALUE
      as if the `defconst' form were instead the form `(define
      identifier value)' .  If IDENTIFIER already has a value, then
-     VALUE is *not* evaluated, IDENTIFIER's value is not changed, and
+     VALUE is _not_ evaluated, IDENTIFIER's value is not changed, and
      an error is signaled.  `defconst' is valid only when used at
      top-level.
 
- - Special Form: set! (VARIABLE1 VARIABLE2 ...) <expression>
+ - Special Form: set! (variable1 variable2 ...) <expression>
      The identifiers VARIABLE1, VARIABLE2, ... must be bound either in
      some region enclosing the `set!' expression or at top level.
 
@@ -2685,12 +2837,12 @@ supported for Posix shell-scripts (*note Scripting::.).
           (define x 2)
           (define y 3)
           (+ x y)                              => 5
-          (set! (x y) (list 4 5))              => *unspecified*
+          (set! (x y) (list 4 5))              => _unspecified_
           (+ x y)                              => 9
 
- - Special Form: casev KEY CLAUSE1 CLAUSE2 ...
-     `casev' is an extension of standard Scheme `case': Each CLAUSE of
-     a `casev' statement must have as first element a list containing
+ - Special Form: qase key clause1 clause2 ...                                 |
+     `qase' is an extension of standard Scheme `case': Each CLAUSE of a       |
+     `qase' statement must have as first element a list containing            |
      elements which are:
 
         * literal datums, or
@@ -2700,7 +2852,7 @@ supported for Posix shell-scripts (*note Scripting::.).
         * a comma followed by an at-sign (@) followed by the name of a
           symbolic constant whose value is a list.
 
-     A `casev' statement is equivalent to a `case' statement in which
+     A `qase' statement is equivalent to a `case' statement in which          |
      these symbolic constants preceded by commas have been replaced by
      the values of the constants, and all symbolic constants preceded by
      comma-at-signs have been replaced by the elements of the list
@@ -2709,19 +2861,19 @@ supported for Posix shell-scripts (*note Scripting::.).
      unquoted expressions must be "symbolic constants".
 
      Symbolic constants are defined using `defconst', their values are
-     substituted in the head of each `casev' clause during macro
+     substituted in the head of each `qase' clause during macro               |
      expansion.  `defconst' constants should be defined before use.
-     `casev' can be substituted for any correct use of `case'.
+     `qase' can be substituted for any correct use of `case'.                 |
 
      (defconst unit '1)
      (defconst semivowels '(w y))
-     (casev (* 2 3)
+     (qase (* 2 3)                                                            |
        ((2 3 5 7) 'prime)
        ((,unit 4 6 8 9) 'composite))        ==>  composite
-     (casev (car '(c d))
+     (qase (car '(c d))                                                       |
        ((a) 'a)
-       ((b) 'b))                            ==>  *unspecified*
-     (casev (car '(c d))
+       ((b) 'b))                            ==>  _unspecified_
+     (qase (car '(c d))                                                       |
        ((a e i o u) 'vowel)
        ((,@semivowels) 'semivowel)
        (else 'consonant))                   ==>  consonant
@@ -2731,13 +2883,85 @@ SCM also supports the following constructs from Common Lisp:
 `defmacro', `macroexpand', `macroexpand-1', and `gentemp'.  *Note
 Defmacro: (slib)Defmacro.
 
+SCM `defmacro' is extended over that described for SLIB:
+
+     (defmacro (macro-name . arguments) body)
+
+is equivalent to
+
+     (defmacro macro-name arguments body)
+
+As in Common Lisp, an element of the formal argument list for
+`defmacro' may be a possibly nested list, in which case the
+corresponding actual argument must be a list with as many members as the
+formal argument.  Rest arguments are indicated by improper lists, as in
+Scheme.  It is an error if the actual argument list does not have the
+tree structure required by the formal argument list.
+
+For example:
+
+     (defmacro (let1 ((name value)) . body)
+         `((lambda (,name) ,@body) ,value))
+     
+     (let1 ((x (foo))) (print x) x) == ((lambda (x) (print x) x) (foo))
+     
+     (let1 not legal syntax) error--> not "does not match" ((name value))
+
+SCM supports [R5RS] `syntax-rules' macros *Note Macros: (r5rs)Macros.
+
+The pattern language is extended by the syntax `(... <obj>)', which is        |
+identical to `<obj>' except that ellipses in `<obj>' are treated as           |
+ordinary identifiers in a template, or as literals in a pattern.  In          |
+particular, `(... ...)' quotes the ellipsis token `...' in a pattern or       |
+template.                                                                     |
+
+For example:
+     (define-syntax check-tree
+       (syntax-rules ()
+         ((_ (?pattern (... ...)) ?obj)
+          (let loop ((obj ?obj))
+            (or (null? obj)
+                (and (pair? obj)
+                     (check-tree ?pattern (car obj))
+                     (loop (cdr obj))))))
+         ((_ (?first . ?rest) ?obj)
+          (let ((obj ?obj))
+            (and (pair? obj)
+                 (check-tree ?first (car obj))
+                 (check-tree ?rest (cdr obj)))))
+         ((_ ?atom ?obj) #t)))
+     
+     (check-tree ((a b) ...) '((1 2) (3 4) (5 6))) => #t
+     
+     (check-tree ((a b) ...) '((1 2) (3 4) not-a-2list) => #f
+
+Note that although the ellipsis is matched as a literal token in the
+defined macro it is not included in the literals list for
+`syntax-rules'.
+
+The pattern language is also extended to support identifier macros.  A
+reference to an identifier macro keyword that is not the first
+identifier in a form may expand into Scheme code, rather than raising a
+"keyword as variable" error.  The pattern for expansion of such a bare
+macro keyword is a single identifier, as in other syntax rules the
+identifier is ignored.
+
+For example:
+     (define-syntax eight
+         (syntax-rules ()
+           (_ 8)))
+     
+     (+ 3 eight) => 11
+     (eight) => ERROR
+     (set! eight 9) => ERROR
+
 
 File: scm.info,  Node: Low Level Syntactic Hooks,  Next: Syntactic Hooks for Hygienic Macros,  Prev: Syntax Extensions,  Up: The Language
 
 Low Level Syntactic Hooks
 =========================
 
- - Callback procedure: read:sharp C PORT
+ - Callback procedure: read:sharp c port
      If a <#> followed by a character (for a non-standard syntax) is
      encountered by `read', `read' will call the value of the symbol
      `read:sharp' with arguments the character and the port being read
@@ -2747,7 +2971,7 @@ Low Level Syntactic Hooks
      whitespace.  `#<unspecified>' is the value returned by the
      expression `(if #f #f)'.
 
- - Callback procedure: read:sharp-char TOKEN
+ - Callback procedure: read:sharp-char token
      If the sequence <#\> followed by a non-standard character name is
      encountered by `read', `read' will call the value of the symbol
      `read:sharp-char' with the token (a string of length at least two)
@@ -2755,19 +2979,20 @@ Low Level Syntactic Hooks
      be the value of `read' for this expression, otherwise an error
      will be signaled.
 
-*Note:* When adding new <#> syntaxes, have your code save the previous
+_Note:_ When adding new <#> syntaxes, have your code save the previous
 value of `read:sharp' or `read:sharp-char' when defining it.  Call this
 saved value if an invocation's syntax is not recognized.  This will
 allow `#+', `#-', `#!', and *Note Uniform Array::s to still be
 supported (as they use `read:sharp').
 
- - Function: procedure->syntax PROC
+ - Function: procedure->syntax proc
      Returns a "macro" which, when a symbol defined to this value
      appears as the first symbol in an expression, returns the result
      of applying PROC to the expression and the environment.
 
- - Function: procedure->macro PROC
- - Function: procedure->memoizing-macro PROC
+ - Function: procedure->macro proc
+ - Function: procedure->memoizing-macro proc
+ - Function: procedure->identifier-macro
      Returns a "macro" which, when a symbol defined to this value
      appears as the first symbol in an expression, evaluates the result
      of applying PROC to the expression and the environment.  The value
@@ -2775,30 +3000,72 @@ supported (as they use `read:sharp').
      `PROCEDURE->MEMOIZING-MACRO' replaces the form passed to PROC.
      For example:
 
-          (define trace
+          (defsyntax trace                                                    |
             (procedure->macro
              (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))
           
           (trace foo) == (set! foo (tracef foo 'foo)).
 
- - Function: environment->tree ENV
-     An "environment" is an opaque object representing lexical bindings.
-     `environment->tree' returns a representation of the environment
-     ENV as a list of environment frames.  There are 2 types of
-     environment frames:
+     `PROCEDURE->IDENTIFIER-MACRO' is similar to
+     `PROCEDURE->MEMOIZING-MACRO' except that PROC is also called in
+     case the symbol bound to the macro appears in an expression but
+     _not_ as the first symbol, that is, when it looks like a variable
+     reference.  In that case, the form passed to PROC is a single
+     identifier.
+
+
+ - Special Form: defsyntax name expr                                          |
+     Defines NAME as a macro keyword bound to the result of evaluating        |
+     EXPR, which should be a macro.  Using `define' for this purpose          |
+     may not result in NAME being interpreted as a macro keyword.             |
+                                                                              |
+An "environment" is a list of frames representing lexical bindings.           |
+Only the names and scope of the bindings are included in environments         |
+passed to macro expanders - run-time values are not included.                 |
+                                                                              |
+There are several types of environment frames:                                |
 
-    `((lambda (variable1 ...) ...) value1 ...)'
-    `(let ((variable1 value1) (variable2 value2) ...) ...)'
-    `(letrec ((variable1 value1)  ...) ...)'
-          result in a single enviroment frame:
-               ((variable1 ...) value1 ...)
+`((lambda (variable1 ...) ...) value1 ...)'
+`(let ((variable1 value1) (variable2 value2) ...) ...)'
+`(letrec ((variable1 value1)  ...) ...)'
+     result in a single enviroment frame:
+                                                                              |
+          (variable1 variable2 ...)                                           |
 
-    `(let ((variable1 value1)) ...)'
-    `(let* ((variable1 value1) ...) ...)'
-          result in an environment frame for each variable:
-               (variable1 . value1) (variable2 .  value2) ...
+`(let ((variable1 value1)) ...)'
+`(let* ((variable1 value1) ...) ...)'
+     result in an environment frame for each variable:
+                                                                              |
+          variable1 variable2 ...                                             |
+                                                                              |
+`(let-syntax ((key1 macro1) (key2 macro2)) ...)'                              |
+`(letrec-syntax ((key1 value1) (key2 value2)) ...)'                           |
+     Lexically bound macros result in environment frames consisting of        |
+     a marker and an alist of keywords and macro objects:                     |
+                                                                              |
+          (<env-syntax-marker> (key1 . value1) (key2 . value2))               |
+     Currently <env-syntax-marker> is the integer 6.                          |
+                                                                              |
+`line numbers'                                                                |
+     Line numbers (*note Line Numbers::) may be included in the               |
+     environment as frame entries to indicate the line number on which        |
+     a function is defined.  They are ignored for variable lookup.            |
+                                                                              |
+          #<line 8>                                                           |
+                                                                              |
+`miscellaneous'                                                               |
+     Debugging information is stored in environments in a plist format:       |
+     Any exact integer stored as an environment frame may be followed         |
+     by any value.  The two frame entries are ignored when doing              |
+     variable lookup.  Load file names, procedure names, and closure          |
+     documentation strings are stored in this format.                         |
+                                                                              |
+          <env-filename-marker> "foo.scm" <env-procedure-name-marker> foo ... |
+                                                                              |
+     Currently <env-filename-marker> is the integer 1 and                     |
+     <env-procedure-name-marker> the integer 2.                               |
 
- - Special Form: @apply PROCEDURE ARGUMENT-LIST
+ - Special Form: @apply procedure argument-list
      Returns the result of applying PROCEDURE to ARGUMENT-LIST.
      `@apply' differs from `apply' when the identifiers bound by the
      closure being applied are `set!'; setting affects ARGUMENT-LIST.
@@ -2810,13 +3077,6 @@ supported (as they use `read:sharp').
      Thus a mutable environment can be treated as both a list and local
      bindings.
 
- - Special Form: @call-with-current-continuation PROCEDURE
-     Returns the result of applying PROCEDURE to the current
-     continuation.  A "continuation" is a SCM object of type `contin'
-     (*note Continuations::.).  The procedure
-     `(call-with-current-continuation PROCEDURE)' is defined to have
-     the same effect as `(@call-with-current-continuation procedure)'.
-
 
 File: scm.info,  Node: Syntactic Hooks for Hygienic Macros,  Prev: Low Level Syntactic Hooks,  Up: The Language
 
@@ -2827,9 +3087,9 @@ SCM provides a synthetic identifier type for efficient implementation of
 hygienic macros (for example, `syntax-rules' *note Macros:
 (r5rs)Macros.) A synthetic identifier may be inserted in Scheme code by
 a macro expander in any context where a symbol would normally be used.
-Collectively, symbols and synthetic identifiers are *identifiers*.
+Collectively, symbols and synthetic identifiers are _identifiers_.
 
- - Function: identifier? OBJ
+ - Function: identifier? obj
      Returns `#t' if OBJ is a symbol or a synthetic identifier, and
      `#f' otherwise.
 
@@ -2842,7 +3102,7 @@ environment which has been passed to a "macro expander" (a procedure
 passed as an argument to `procedure->macro',
 `procedure->memoizing-macro', or `procedure->syntax').
 
- - Function: renamed-identifier PARENT ENV
+ - Function: renamed-identifier parent env
      Returns a synthetic identifier.  PARENT must be an identifier, and
      ENV must either be `#f' or a lexical environment passed to a macro
      expander.  `renamed-identifier' returns a distinct object for each
@@ -2853,7 +3113,7 @@ identifier, those data are used during variable lookup.  If a synthetic
 identifier is inserted as quoted data then during macro expansion it
 will be repeatedly replaced by its parent, until a symbol is obtained.
 
- - Function: identifier->symbol ID
+ - Function: identifier->symbol id
      Returns the symbol obtained by recursively extracting the parent of
      ID, which must be an identifier.
 
@@ -2868,7 +3128,8 @@ Use of synthetic identifiers
 
 If an identifier returned by this version of `gentemp' is inserted in a
 binding position as the name of a variable then it is guaranteed that
-no other identifier may denote that variable.  If an identifier
+no other identifier (except one produced by passing the first to
+`renamed-identifier') may denote that variable.  If an identifier
 returned by `gentemp' is inserted free, then it will denote the
 top-level value bound to its parent, the symbol named "An unlikely
 variable".  This behavior, of course, is meant to be put to good use:
@@ -2890,31 +3151,25 @@ In other words, we can avoid capturing `foo'.
 If a lexical environment is passed as the second argument to
 `renamed-identifier' then if the identifier is inserted free its parent
 will be looked up in that environment, rather than in the top-level
-environment.  The use of such an identifier *must* be restricted to the
+environment.  The use of such an identifier _must_ be restricted to the
 lexical scope of its environment.
 
 There is another restriction imposed for implementation convenience:
 Macros passing their lexical environments to `renamed-identifier' may
-be lexically bound only by the special forms `@let-syntax' or
-`@letrec-syntax'.  No error is signaled if this restriction is not met,
+be lexically bound only by the special forms `let-syntax' or                  |
+`letrec-syntax'.  No error is signaled if this restriction is not met,        |
 but synthetic identifier lookup will not work properly.
-
- - Special Form: @let-syntax
- - Special Form: @letrec-syntax
-     Behave as `let' and `letrec', but may also put extra information
-     in the lexical environment so that `renamed-identifier' will work
-     properly during expansion of the macros bound by these forms.
-
+                                                                              |
 In order to maintain referential transparency it is necessary to
 determine whether two identifiers have the same denotation.  With
 synthetic identifiers it is not necessary that two identifiers be `eq?'
 in order to denote the same binding.
 
- - Function: identifier-equal? ID1 ID2 ENV
+ - Function: identifier-equal? id1 id2 env
      Returns `#t' if identifiers ID1 and ID2 denote the same binding in
-     lexical environment ENV, and `#f' otherwise.  ENV must be a
+     lexical environment ENV, and `#f' otherwise.  ENV must either be a
      lexical environment passed to a macro transformer during macro
-     expansion.
+     expansion or the empty list.
 
      For example,
           (define top-level-foo?
@@ -2928,13 +3183,13 @@ in order to denote the same binding.
           (let ((foo 'local))
             (top-level-foo? foo))  => #f
 
- - Function: @macroexpand1 EXPR ENV
+ - Function: @macroexpand1 expr env
      If the `car' of EXPR denotes a macro in ENV, then if that macro is
      a primitive, EXPR will be returned, if the macro was defined in
      Scheme, then a macro expansion will be returned.  If the `car' of
      EXPR does not denote a macro, the `#f' is returned.
 
- - Function: extended-environment NAMES VALUES ENV
+ - Function: extended-environment names values env
      Returns a new environment object, equivalent to ENV, which must
      either be an environment object or null, extended by one frame.
      NAMES must be an identifier, or an improper list of identifiers,
@@ -2944,13 +3199,13 @@ in order to denote the same binding.
      list then VALS may be, respectively, any object or an improper
      list of objects.
 
- - Special Form: syntax-quote OBJ
+ - Special Form: syntax-quote obj
      Synthetic identifiers are converted to their parent symbols by
      `quote' and `quasiquote' so that literal data in macro definitions
      will be properly transcribed.  `syntax-quote' behaves like
      `quote', but preserves synthetic identifier intact.
 
- - Special Form: the-macro MAC
+ - Special Form: the-macro mac
      `the-macro' is the simplest of all possible macro transformers:
      MAC may be a syntactic keyword (macro name) or an expression
      evaluating to a macro, otherwise an error is signaled.  MAC is
@@ -2963,18 +3218,18 @@ in order to denote the same binding.
              ;; code that will continue to work even if LET is redefined.
                   ...)
 
- - Special Form: renaming-transformer PROC
+ - Special Form: renaming-transformer proc
      A low-level "explicit renaming" macro facility very similar to that
      proposed by W. Clinger [Exrename] is supported.  Syntax may be
      defined in `define-syntax', `let-syntax', and `letrec-syntax'
      using `renaming-transformer' instead of `syntax-rules'.  PROC
      should evaluate to a procedure accepting three arguments: EXPR,
-     RENAME, and COMPARE. EXPR is a representation of Scheme code to be
-     expanded, as list structure.  RENAME is a procedure accepting an
-     identifier and returning an identifier renamed in the definition
-     environment of the new syntax.  COMPARE accepts two identifiers
-     and returns true if and only if both denote the same binding in
-     the usage environment of the new syntax.
+     RENAME, and COMPARE.  EXPR is a representation of Scheme code to
+     be expanded, as list structure.  RENAME is a procedure accepting
+     an identifier and returning an identifier renamed in the
+     definition environment of the new syntax.  COMPARE accepts two
+     identifiers and returns true if and only if both denote the same
+     binding in the usage environment of the new syntax.
 
 
 File: scm.info,  Node: Packages,  Next: The Implementation,  Prev: The Language,  Up: Top
@@ -2983,14 +3238,15 @@ Packages
 ********
 
 * Menu:
-
-* Compiling And Linking::       Hobbit
+                                                                              |
 * Dynamic Linking::
 * Dump::                        Create Fast-Booting Executables
 * Numeric::                     Numeric Language Extensions
 * Arrays::                      As in APL
+* Records::                     Define new aggregate data types               |
 * I/O-Extensions::              i/o-extensions
 * Posix Extensions::            posix
+* Unix Extensions::             non-posix unix                                |
 * Regular Expression Pattern Matching::  regex
 * Line Editing::                edit-line
 * Curses::                      Screen Control
@@ -2999,57 +3255,11 @@ Packages
 * Menu:
 
 * Xlib: (Xlibscm).              X Window Graphics.
+* Hobbit: (hobbit).             Scheme-to-C Compiler.                         |
 
 
-File: scm.info,  Node: Compiling And Linking,  Next: Dynamic Linking,  Prev: Packages,  Up: Packages
-
-Compiling And Linking
-=====================
-
- - Function: compile-file NAME1 NAME2 ...
-     If the HOBBIT compiler is installed in the
-     `(implementation-vicinity)', compiles the files NAME1 NAME2 ... to
-     an object file name NAME1<object-suffix>, where <object-suffix> is
-     the object file suffix for your computer (for instance, `.o').
-     NAME1 must be in the current directory; NAME2 ... can be in other
-     directories.
-
- - Function: link-named-scm NAME MODULE1 ...
-     Creates a new SCM executable with name NAME.  NAME will include
-     the object modules MODULE1 ... which can be produced with
-     `compile-file'.
-
-          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/Init5d2.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")
-          ...
-          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
-
-
-File: scm.info,  Node: Dynamic Linking,  Next: Dump,  Prev: Compiling And Linking,  Up: Packages
-
+File: scm.info,  Node: Dynamic Linking,  Next: Dump,  Prev: Packages,  Up: Packages
+                                                                              |
 Dynamic Linking
 ===============
 
@@ -3057,24 +3267,24 @@ If SCM has been compiled with `dynl.c' then the additional properties
 of load and ([SLIB]) require specified here are supported.  The
 `require' form is preferred.
 
- - Function: require FEATURE
+ - Function: require feature
      If the symbol FEATURE has not already been given as an argument to
      `require', then the object and library files associated with
      FEATURE will be dynamically-linked, and an unspecified value
      returned.  If FEATURE is not found in `*catalog*', then an error
      is signaled.
 
- - Function: usr:lib LIB
+ - Function: usr:lib lib
      Returns the pathname of the C library named LIB.  For example:
      `(usr:lib "m")' returns `"/usr/lib/libm.a"', the path of the C
      math library.
 
- - Function: x:lib LIB
+ - Function: x:lib lib
      Returns the pathname of the X library named LIB.  For example:
      `(x:lib "X11")' returns `"/usr/X11/lib/libX11.sa"', the path of
      the X11 library.
 
- - Function: load FILENAME LIB1 ...
+ - Function: load filename lib1 ...
      In addition to the [R5RS] requirement of loading Scheme
      expressions if FILENAME is a Scheme source file, `load' will also
      dynamically load/link object files (produced by `compile-file', for
@@ -3103,7 +3313,7 @@ of load and ([SLIB]) require specified here are supported.  The
           or (require 'turtle-graphics)
 
      And the string regular expression (*note Regular Expression
-     Pattern Matching::.) package is linked by:
+     Pattern Matching::) package is linked by:
 
           (load (in-vicinity (implementation-vicinity) "rgx") (usr:lib "c"))
      or
@@ -3113,7 +3323,7 @@ The following functions comprise the low-level Scheme interface to
 dynamic linking.  See the file `Link.scm' in the SCM distribution for
 an example of their use.
 
- - Function: dyn:link FILENAME
+ - Function: dyn:link filename
      FILENAME should be a string naming an "object" or "archive" file,
      the result of C-compiling.  The `dyn:link' procedure links and
      loads FILENAME into the current SCM session.  If successfull,
@@ -3121,7 +3331,7 @@ an example of their use.
      second argument to `dyn:call'.  If not successful, `#f' is
      returned.
 
- - Function: dyn:call NAME LINK-TOKEN
+ - Function: dyn:call name link-token
      LINK-TOKEN should be the value returned by a call to `dyn:link'.
      NAME should be the name of C function of no arguments defined in
      the file named FILENAME which was succesfully `dyn:link'ed in the
@@ -3133,7 +3343,7 @@ an example of their use.
      SCM object files.  The init_... function then makes the
      identifiers defined in the file accessible as Scheme procedures.
 
- - Function: dyn:main-call NAME LINK-TOKEN ARG1 ...
+ - Function: dyn:main-call name link-token arg1 ...
      LINK-TOKEN should be the value returned by a call to `dyn:link'.
      NAME should be the name of C function of 2 arguments, `(int argc,
      char **argv)', defined in the file named FILENAME which was
@@ -3145,10 +3355,10 @@ an example of their use.
 
      `dyn:main-call' can be used to call a `main' procedure from SCM.
      For example, I link in and `dyn:main-call' a large C program, the
-     low level routines of which callback (*note Callbacks::.) into SCM
+     low level routines of which callback (*note Callbacks::) into SCM
      (which emulates PCI hardware).
 
- - Function: dyn:unlink LINK-TOKEN
+ - Function: dyn:unlink link-token
      LINK-TOKEN should be the value returned by a call to `dyn:link'.
      The `dyn:unlink' procedure removes the previously loaded file from
      the current SCM session.  If successful, `dyn:unlink' returns
@@ -3170,10 +3380,10 @@ There are constraints on which sessions are savable using `dump'
    * Saved continuations are invalid in subsequent invocations; they
      cause segmentation faults and other unpleasant side effects.
 
-   * Although DLD (*note Dynamic Linking::.) can be used to load
-     compiled modules both before and after dumping, `SUN_DL' ELF
-     systems can load compiled modules only after dumping.  This can be
-     worked around by compiling in those features you wish to `dump'.
+   * Although DLD (*note Dynamic Linking::) can be used to load compiled
+     modules both before and after dumping, `SUN_DL' ELF systems can
+     load compiled modules only after dumping.  This can be worked
+     around by compiling in those features you wish to `dump'.
 
    * Ports (other than `current-input-port', `current-output-port',
      `current-error-port'), X windows, etc. are invalid in subsequent
@@ -3186,17 +3396,17 @@ There are constraints on which sessions are savable using `dump'
 
    * `Dump' can be called from the command line.
 
- - Function: dump NEWPATH
- - Function: dump NEWPATH #F
- - Function: dump NEWPATH #T
- - Function: dump NEWPATH THUNK
+ - Function: dump newpath
+ - Function: dump newpath #f
+ - Function: dump newpath #t
+ - Function: dump newpath thunk
         * Calls `gc'.
 
         * Creates an executable program named NEWPATH which continues
           the state of the current SCM session when invoked.  The
           optional argument THUNK, if provided, should be a procedure
-          of no arguments.  This procedure will be called in the
-          restored executable.
+          of no arguments; BOOT-TAIL will be set to this procedure,           |
+          causing it to 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
@@ -3216,18 +3426,15 @@ There are constraints on which sessions are savable using `dump'
      *INTERACTIVE*.  `dump' returns an unspecified value.
 
 When a dumped executable is invoked, the variable *INTERACTIVE* (*note
-Internal State::.) has the value it possessed when `dump' created it.
+Internal State::) has the value it possessed when `dump' created it.
 Calling `dump' with a single argument sets *INTERACTIVE* to `#f', which
 is the state it has at the beginning of command line processing.
 
 The procedure `program-arguments' returns the command line arguments
 for the curent invocation.  More specifically, `program-arguments' for
-the restored session are *not* saved from the dumping session.  Command
+the restored session are _not_ saved from the dumping session.  Command
 line processing is done on the value of the identifier `*argv*'.
-
-The thunk `boot-tail' is called by SCM to process command line
-arguments.  `dump' sets `boot-tail' to the THUNK it is called with.
-
+                                                                              |
 The following example shows how to create `rscm', which is like regular
 scm, but which loads faster and has the `random' package alreadly
 provided.
@@ -3244,7 +3451,7 @@ provided.
      bash$
 
 This task can also be accomplished using the `-o' command line option
-(*note SCM Options::.).
+(*note SCM Options::).
 
      bash$ scm -rrandom -o rscm
      > (quit)
@@ -3268,53 +3475,63 @@ Numeric
  - Constant: most-negative-fixnum
      The immediate integer closest to negative infinity.
 
+ - Constant: $pi
+ - Constant: pi
+     The ratio of the circumference to the diameter of a circle.
+
 These procedures augment the standard capabilities in *Note Numerical
 operations: (r5rs)Numerical operations.
 
- - Function: sinh Z
- - Function: cosh Z
- - Function: tanh Z
+ - Function: pi* z
+     `(* pi Z)'
+
+ - Function: pi/ z
+     `(/ pi Z)'
+
+ - Function: sinh z
+ - Function: cosh z
+ - Function: tanh z
      Return the hyperbolic sine, cosine, and tangent of Z
 
- - Function: asinh Z
- - Function: acosh Z
- - Function: atanh Z
+ - Function: asinh z
+ - Function: acosh z
+ - Function: atanh z
      Return the inverse hyperbolic sine, cosine, and tangent of Z
 
- - Function: $sqrt X
- - Function: $abs X
- - Function: $exp X
- - Function: $log X
- - Function: $sin X
- - Function: $cos X
- - Function: $tan X
- - Function: $asin X
- - Function: $acos X
- - Function: $atan X
- - Function: $sinh X
- - Function: $cosh X
- - Function: $tanh X
- - Function: $asinh X
- - Function: $acosh X
- - Function: $atanh X
+ - Function: $sqrt x
+ - Function: $abs x
+ - Function: $exp x
+ - Function: $log x
+ - Function: $sin x
+ - Function: $cos x
+ - Function: $tan x
+ - Function: $asin x
+ - Function: $acos x
+ - Function: $atan x
+ - Function: $sinh x
+ - Function: $cosh x
+ - Function: $tanh x
+ - Function: $asinh x
+ - Function: $acosh x
+ - Function: $atanh x
      Real-only versions of these popular functions.  The argument X
      must be a real number.  It is an error if the value which should be
-     returned by a call to these procedures is *not* real.
+     returned by a call to these procedures is _not_ real.
 
- - Function: $log10 X
+ - Function: $log10 x
      Real-only base 10 logarithm.
 
- - Function: $atan2 Y X
+ - Function: $atan2 y x
      Computes `(angle (make-rectangular x y))' for real numbers Y and X.
 
- - Function: $expt X1 X2
+ - Function: $expt x1 x2
      Returns real number X1 raised to the real power X2.  It is an
      error if the value which should be returned by a call to `$expt'
      is not real.
 
 
-File: scm.info,  Node: Arrays,  Next: I/O-Extensions,  Prev: Numeric,  Up: Packages
-
+File: scm.info,  Node: Arrays,  Next: Records,  Prev: Numeric,  Up: Packages
+                                                                              |
 Arrays
 ======
 
@@ -3350,24 +3567,24 @@ indices expressed as a two element list, or an upper bound expressed as
 a single integer.  So
      (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2))
 
- - Function: array? OBJ
+ - Function: array? obj
      Returns `#t' if the OBJ is an array, and `#f' if not.
 
- - Function: make-array INITIAL-VALUE BOUND1 BOUND2 ...
+ - Function: make-array initial-value bound1 bound2 ...
      Creates and returns an array that has as many dimensions as there
      are BOUNDs and fills it with INITIAL-VALUE.
 
- - Function: array-ref ARRAY INDEX1 INDEX2 ...
+ - Function: array-ref array index1 index2 ...
      Returns the INDEX1, INDEX2, ...'th element of ARRAY.
 
- - Function: array-in-bounds? ARRAY INDEX1 INDEX2 ...
+ - Function: array-in-bounds? array index1 index2 ...
      Returns `#t' if its arguments would be acceptable to ARRAY-REF.
 
- - Function: array-set! ARRAY NEW-VALUE INDEX1 INDEX2 ...
+ - Function: array-set! array new-value index1 index2 ...
      Sets the INDEX1, INDEX2, ...'th element of ARRAY to NEW-VALUE.
      The value returned by `array-set!' is unspecified.
 
- - Function: make-shared-array ARRAY MAPPER BOUND1 BOUND2 ...
+ - Function: make-shared-array array mapper bound1 bound2 ...
      `make-shared-array' can be used to create shared subarrays of other
      arrays.  The MAPPER is a function that translates coordinates in
      the new array into coordinates in the old array.  A MAPPER must be
@@ -3382,7 +3599,7 @@ a single integer.  So
             (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))
           (array-ref freds-center 0 0) => foo
 
- - Function: transpose-array ARRAY DIM0 DIM1 ...
+ - Function: transpose-array array dim0 dim1 ...
      Returns an array sharing contents with ARRAY, but with dimensions
      arranged in a different order.  There must be one DIM argument for
      each dimension of ARRAY.  DIM0, DIM1, ... should be integers
@@ -3400,7 +3617,7 @@ a single integer.  So
           (transpose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) =>
                           #2A((a 4) (b 5) (c 6))
 
- - Function: enclose-array ARRAY DIM0 DIM1 ...
+ - Function: enclose-array array dim0 dim1 ...
      DIM0, DIM1 ... should be nonnegative integers less than the rank
      of ARRAY.  ENCLOSE-ARRAY returns an array resembling an array of
      shared arrays.  The dimensions of each shared array are the same
@@ -3421,51 +3638,50 @@ a single integer.  So
           (enclose-array '#3A(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) =>
              #<enclosed-array #2A((a 1) (d 4)) #2A((b 2) (e 5)) #2A((c 3) (f 6))>
 
- - Function: array-shape ARRAY
+ - Function: array-shape array
      Returns a list of inclusive bounds of integers.
           (array-shape (make-array 'foo '(-1 3) 5)) => ((-1 3) (0 4))
 
- - Function: array-dimensions ARRAY
+ - Function: array-dimensions array
      `Array-dimensions' is similar to `array-shape' but replaces
-     elements with a `0' minimum with one greater than the maximum. So:
+     elements with a `0' minimum with one greater than the maximum.  So:
           (array-dimensions (make-array 'foo '(-1 3) 5)) => ((-1 3) 5)
 
- - Function: array-rank OBJ
+ - Function: array-rank obj
      Returns the number of dimensions of OBJ.  If OBJ is not an array,
      `0' is returned.
 
- - Function: array->list ARRAY
+ - Function: array->list array
      Returns a list consisting of all the elements, in order, of ARRAY.
      In the case of a rank-0 array, returns the single element.
 
- - Function: array-copy! SOURCE DESTINATION
+ - Function: array-copy! source destination
      Copies every element from vector or array SOURCE to the
      corresponding element of DESTINATION.  DESTINATION must have the
      same rank as SOURCE, and be at least as large in each dimension.
      The order of copying is unspecified.
 
- - Function: serial-array-copy! SOURCE DESTINATION
+ - Function: serial-array-copy! source destination
      Same as `array-copy!' but guaranteed to copy in row-major order.
 
- - Function: array-fill! ARRAY FILL
+ - Function: array-fill! array fill
      Stores FILL in every element of ARRAY.  The value returned is
      unspecified.
 
- - Function: array-equal? ARRAY0 ARRAY1 ...
+ - Function: array-equal? array0 array1 ...
      Returns `#t' iff all arguments are arrays with the same shape, the
      same type, and have corresponding elements which are either
      `equal?'  or `array-equal?'.  This function differs from `equal?'
      in that a one dimensional shared array may be ARRAY-EQUAL? but not
      EQUAL? to a vector or uniform vector.
 
- - Function: array-contents ARRAY
- - Function: array-contents ARRAY STRICT
+ - Function: array-contents array
+ - Function: array-contents array strict
      If ARRAY may be "unrolled" into a one dimensional shared array
      without changing their order (last subscript changing fastest),
      then `array-contents' returns that shared array, otherwise it
-     returns `#f'.  All arrays made by MAKE-ARRAY and
-     MAKE-UNIFORM-ARRAY may be unrolled, some arrays made by
-     MAKE-SHARED-ARRAY may not be.
+     returns `#f'.  All arrays made by MAKE-ARRAY and CREATE-ARRAY may        |
+     be unrolled, some arrays made by MAKE-SHARED-ARRAY may not be.           |
 
      If the optional argument STRICT is provided, a shared array will
      be returned only if its elements are stored internally contiguous
@@ -3479,7 +3695,7 @@ Array Mapping
 
 `(require 'array-for-each)'
 
- - Function: array-map! ARRAY0 PROC ARRAY1 ...
+ - Function: array-map! array0 proc array1 ...
      If ARRAY1, ... are arrays, they must have the same number of
      dimensions as ARRAY0 and have a range for each index which
      includes the range for the corresponding index in ARRAY0.  If they
@@ -3491,15 +3707,15 @@ Array Mapping
      unspecified.
 
 
- - Function: serial-array-map! ARRAY0 PROC ARRAY1 ...
+ - Function: serial-array-map! array0 proc array1 ...
      Same as ARRAY-MAP!, but guaranteed to apply PROC in row-major
      order.
 
- - Function: array-for-each PROC ARRAY0 ...
+ - Function: array-for-each proc array0 ...
      PROC is applied to each tuple of elements of ARRAY0 ...  in
      row-major order.  The value returned is unspecified.
 
- - Function: array-index-map! ARRAY PROC
+ - Function: array-index-map! array proc
      applies PROC to the indices of each element of ARRAY in turn,
      storing the result in the corresponding element.  The value
      returned and the order of application are unspecified.
@@ -3511,11 +3727,11 @@ Array Mapping
                 ra))
      Another example:
           (define (apl:index-generator n)
-              (let ((v (make-uniform-vector n 1)))
+              (let ((v (make-vector n 1)))                                    |
                 (array-index-map! v (lambda (i) i))
                 v))
 
- - Function: scalar->array SCALAR ARRAY PROTOTYPE
+ - Function: scalar->array scalar array prototype
      Returns a uniform array of the same shape as ARRAY, having only
      one shared element, which is `eqv?' to SCALAR.  If the optional
      argument PROTOTYPE is supplied it will be used as the prototype
@@ -3535,59 +3751,51 @@ same type.  Uniform vectors occupy less storage than conventional
 vectors.  Uniform Array procedures also work on vectors,
 uniform-vectors, bit-vectors, and strings.
 
-PROTOTYPE arguments in the following procedures are interpreted
-according to the table:
-
-     prototype       type                             display prefix
-     
-     #t              boolean (bit-vector)                    #At
-     #\a             char (string)                           #A\
-     integer >0      unsigned integer                        #Au
-     integer <0      signed integer                          #Ae
-     1.0             float (single precision)                #Aif
-     1/3             double (double precision float)         #Aid
-     +i              complex (double precision)              #Aic
-     ()              conventional vector                     #A
+SLIB now supports uniform arrys.  The primary array creation procedure        |
+is `create-array', detailed in *Note Arrays: (slib)Arrays.                    |
 
 Unshared uniform character 0-based arrays of rank 1 (dimension) are
 equivalent to (and can't be distinguished from) strings.
-     (make-uniform-array #\a 3) => "$q2"
+     (create-array "" 3) => "$q2"                                             |
 
 Unshared uniform boolean 0-based arrays of rank 1 (dimension) are
 equivalent to (and can't be distinguished from) *Note bit-vectors: Bit
 Vectors.
-     (make-uniform-array #t 3) => #*000
+     (create-array '#at() 3) => #*000                                         |
      ==
      #At(#f #f #f) => #*000
      ==
      #1At(#f #f #f) => #*000
 
-Other uniform vectors are written in a form similar to that of general
-arrays, except that one or more modifying characters are put between
-the #\A character and the contents list.  For example, `'#Ae(3 5 9)'
-returns a uniform vector of signed integers.
+PROTOTYPE arguments in the following procedures are interpreted               |
+according to the table:                                                       |
 
- - Function: uniform-vector-ref UVE INDEX
-     Returns the element at the INDEX element in UVE.
-
- - Function: uniform-vector-set! UVE INDEX NEW-VALUE
-     Sets the element at the INDEX element in UVE to NEW-VALUE.  The
-     value returned by `uniform-vector-set!' is unspecified.
+     prototype       type                              display prefix         |
+     
+     ()              conventional vector                     #a               |
+     +64i            complex (double precision)              #ac64            |
+     64.0            double (double precision)               #ar64            |
+     32.0            float (single precision)                #ar32            |
+     32              unsigned integer (32-bit)               #au32            |
+     -32             signed integer (32-bit)                 #as32            |
+     -16             signed integer (16-bit)                 #as16            |
+     #\a             char (string)                           #a\              |
+     #t              boolean (bit-vector)                    #at              |
+                                                                              |
+Other uniform vectors are written in a form similar to that of general        |
+arrays, except that one or more modifying characters are put between the      |
+#\A character and the contents list.  For example, `'#As32(3 5 9)'            |
+returns a uniform vector of signed integers.                                  |
 
- - Function: array? OBJ PROTOTYPE
+ - Function: array? obj prototype
      Returns `#t' if the OBJ is an array of type corresponding to
      PROTOTYPE, and `#f' if not.
-
- - Function: make-uniform-array PROTOTYPE BOUND1 BOUND2 ...
-     Creates and returns a uniform array of type corresponding to
-     PROTOTYPE that has as many dimensions as there are BOUNDs.
-
- - Function: array-prototype ARRAY
+                                                                              |
+ - Function: array-prototype array
      Returns an object that would produce an array of the same type as
-     ARRAY, if used as the PROTOTYPE for `make-uniform-array'.
+     ARRAY, if used as the PROTOTYPE for `list->uniform-array'.               |
 
- - Function: list->uniform-array RANK PROT LST
- - Function: list->uniform-vector PROT LST
+ - Function: list->uniform-array rank prot lst                                |
      Returns a uniform array of the type indicated by prototype PROT
      with elements the same as those of LST.  Elements must be of the
      appropriate type, no coercions are done.
@@ -3600,26 +3808,19 @@ returns a uniform vector of signed integers.
      If RANK is zero, LST, which need not be a list, is the single
      element of the returned array.
 
- - Function: uniform-vector-fill! UVE FILL
+ - Function: uniform-vector-fill! uve fill
      Stores FILL in every element of UVE.  The value returned is
      unspecified.
-
- - Function: uniform-vector-length UVE
-     Returns the number of elements in UVE.
-
- - Function: dimensions->uniform-array DIMS PROTOTYPE FILL
- - Function: dimensions->uniform-array DIMS PROTOTYPE
- - Function: make-uniform-vector LENGTH PROTOTYPE FILL
- - Function: make-uniform-vector LENGTH PROTOTYPE
+                                                                              |
+ - Function: dimensions->uniform-array dims prototype fill
+ - Function: dimensions->uniform-array dims prototype                         |
      Creates and returns a uniform array or vector of type
      corresponding to PROTOTYPE with dimensions DIMS or length LENGTH.
      If the FILL argument is supplied, the returned array is filled with
      this value.
 
- - Function: uniform-array-read! URA
- - Function: uniform-array-read! URA PORT
- - Function: uniform-vector-read! UVE
- - Function: uniform-vector-read! UVE PORT
+ - Function: uniform-array-read! ura
+ - Function: uniform-array-read! ura port                                     |
      Attempts to read all elements of URA, in lexicographic order, as
      binary objects from PORT.  If an end of file is encountered during
      uniform-array-read! the objects up to that point only are put into
@@ -3630,16 +3831,14 @@ returns a uniform vector of signed integers.
      may be omitted, in which case it defaults to the value returned by
      `(current-input-port)'.
 
- - Function: uniform-array-write URA
- - Function: uniform-array-write URA PORT
- - Function: uniform-vector-write UVE
- - Function: uniform-vector-write UVE PORT
-     Writes all elements of URA as binary objects to PORT. The number
-     of of objects actually written is returned. PORT may be omitted,
+ - Function: uniform-array-write ura
+ - Function: uniform-array-write ura port                                     |
+     Writes all elements of URA as binary objects to PORT.  The number
+     of of objects actually written is returned.  PORT may be omitted,
      in which case it defaults to the value returned by
      `(current-output-port)'.
 
- - Function: logaref ARRAY INDEX1 INDEX2 ...
+ - Function: logaref array index1 index2 ...
      If an INDEX is provided for each dimension of ARRAY returns the
      INDEX1, INDEX2, ...'th element of ARRAY.  If one more INDEX is
      provided, then the last index specifies bit position of the
@@ -3651,7 +3850,7 @@ returns a uniform vector of signed integers.
           (logaref '#(#b1101 #b0010) 0 1)     => #f
           (logaref '#2((#b1101 #b0010)) 0 0)  => #b1101
 
- - Function: logaset! ARRAY VAL INDEX1 INDEX2 ...
+ - Function: logaset! array val index1 index2 ...
      If an INDEX is provided for each dimension of ARRAY sets the
      INDEX1, INDEX2, ...'th element of ARRAY to VAL.  If one more INDEX
      is provided, then the last index specifies bit position of the
@@ -3674,18 +3873,18 @@ prefixed by `#*'.
 Some of these operations will eventually be generalized to other
 uniform-arrays.
 
- - Function: bit-count BOOL BV
+ - Function: bit-count bool bv
      Returns the number occurrences of BOOL in BV.
 
- - Function: bit-position BOOL BV K
+ - Function: bit-position bool bv k
      Returns the minimum index of an occurrence of BOOL in BV which is
      at least K.  If no BOOL occurs within the specified range `#f' is
      returned.
 
- - Function: bit-invert! BV
+ - Function: bit-invert! bv
      Modifies BV by replacing each element with its negation.
 
- - Function: bit-set*! BV UVE BOOL
+ - Function: bit-set*! bv uve bool
      If uve is a bit-vector BV and uve must be of the same length.  If
      BOOL is `#t', uve is OR'ed into BV; If BOOL is `#f', the inversion
      of uve is AND'ed into BV.
@@ -3696,25 +3895,47 @@ uniform-arrays.
 
      The return value is unspecified.
 
- - Function: bit-count* BV UVE BOOL
+ - Function: bit-count* bv uve bool
      Returns
           (bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).
      BV is not modified.
 
 
-File: scm.info,  Node: I/O-Extensions,  Next: Posix Extensions,  Prev: Arrays,  Up: Packages
-
+File: scm.info,  Node: Records,  Next: I/O-Extensions,  Prev: Arrays,  Up: Packages
+                                                                              |
+Records                                                                       |
+=======                                                                       |
+                                                                              |
+SCM provides user-definable datatypes with the same interface as SLIB,        |
+see *Note Records: (slib)Records, with the following extension.               |
+                                                                              |
+ - Function: record-printer-set! rtd printer                                  |
+     Causes records of type RTD to be printed in a user-specified             |
+     format.  RTD must be a record type descriptor returned by                |
+     `make-record-type', PRINTER a procedure accepting three arguments:       |
+     the record to be printed, the port to print to, and a boolean            |
+     which is true if the record is being written on behalf of `write'        |
+     and false if for `display'.  If PRINTER returns #f, the default          |
+     record printer will be called.                                           |
+                                                                              |
+     A PRINTER value of #f means use the default printer.                     |
+                                                                              |
+     Only the default printer will be used when printing error messages.      |
+                                                                              |
+
+File: scm.info,  Node: I/O-Extensions,  Next: Posix Extensions,  Prev: Records,  Up: Packages
+                                                                              |
 I/O-Extensions
 ==============
 
 If `'i/o-extensions' is provided (by linking in `ioext.o'), *Note Line
 I/O: (slib)Line I/O, and the following functions are defined:
 
- - Function: stat <PORT-OR-STRING>
+ - Function: 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
+     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
      `#f' is returned.  The elements of the returned vector are as
@@ -3756,60 +3977,67 @@ I/O: (slib)Line I/O, and the following functions are defined:
  - Function: getpid
      Returns the process ID of the current process.
 
- - Function: file-position PORT
+ - Function: file-position port
      Returns the current position of the character in PORT which will
      next be read or written.  If PORT is not open to a file the result
      is unspecified.
 
- - Function: file-set-position PORT INTEGER
+ - Function: file-set-position port integer
      Sets the current position in PORT which will next be read or
      written.  If PORT is not open to a file the action of
      `file-set-position' is unspecified.  The result of
      `file-set-position' is unspecified.
 
- - Function: reopen-file FILENAME MODES PORT
+ - Function: try-create-file name modes perms                                 |
+     If the file with name NAME already exists, return `#f', otherwise        |
+     try to create and open the file like `try-open-file', *Note Files
+     and Ports::.  If the optional integer argument PERMS is provided,        |
+     it is used as the permissions of the new file (modified by the           |
+     current umask).                                                          |
+                                                                              |
+ - Function: reopen-file filename modes port
      Closes port PORT and reopens it with FILENAME and MODES.
      `reopen-file' returns `#t' if successful, `#f' if not.
 
- - Function: duplicate-port PORT MODES
+ - Function: duplicate-port port modes
      Creates and returns a "duplicate" port from PORT.  Duplicate
-     *unbuffered* ports share one file position.  MODES are as for
+     _unbuffered_ ports share one file position.  MODES are as for
      *Note open-file: Files and Ports.
 
- - Function: redirect-port! FROM-PORT TO-PORT
+ - Function: redirect-port! from-port to-port
      Closes TO-PORT and makes TO-PORT be a duplicate of FROM-PORT.
      `redirect-port!' returns TO-PORT if successful, `#f' if not.  If
      unsuccessful, TO-PORT is not closed.
 
- - Function: opendir DIRNAME
+ - Function: opendir dirname
      Returns a "directory" object corresponding to the file system
      directory named DIRNAME.  If unsuccessful, returns `#f'.
 
- - Function: readdir DIR
+ - Function: readdir dir
      Returns the string name of the next entry from the directory DIR.
      If there are no more entries in the directory, `readdir' returns a
      `#f'.
 
- - Function: rewinddir DIR
+ - Function: rewinddir dir
      Reinitializes DIR so that the next call to `readdir' with DIR will
      return the first entry in the directory again.
 
- - Function: closedir DIR
+ - Function: closedir dir
      Closes DIR and returns `#t'.  If DIR is already closed,,
      `closedir' returns a `#f'.
 
- - Function: directory-for-each PROC DIRECTORY
+ - Function: directory-for-each proc directory
      The LISTs must be lists, and PROC must be a procedure taking one
      argument.  `Directory-For-Each' applies PROC to the (string) name
      of each file in DIRECTORY.  The dynamic order in which PROC is
      applied to the elements of the LISTs is unspecified.  The value
      returned by `directory-for-each' is unspecified.
 
- - Function: directory-for-each PROC DIRECTORY PRED
+ - Function: directory-for-each proc directory pred
      Applies PROC only to those filenames for which the procedure PRED
      returns a non-false value.
 
- - Function: directory-for-each PROC DIRECTORY MATCH
+ - Function: directory-for-each proc directory match
      Applies PROC only to those filenames for which `(filename:match??
      MATCH)' would return a non-false value (*note Filenames:
      (slib)Filenames.).
@@ -3822,9 +4050,9 @@ I/O: (slib)Line I/O, and the following functions are defined:
           "Link.scm"
           "Macro.scm"
           "Transcen.scm"
-          "Init5d2.scm"                                                       |
+          "Init5d6.scm"                                                       |
 
- - Function: mkdir PATH MODE
+ - Function: mkdir path mode
      The `mkdir' function creates a new, empty directory whose name is
      PATH.  The integer argument MODE specifies the file permissions
      for the new directory.  *Note The Mode Bits for Access Permission:
@@ -3833,12 +4061,12 @@ I/O: (slib)Line I/O, and the following functions are defined:
 
      `mkdir' returns if successful, `#f' if not.
 
- - Function: rmdir PATH
+ - Function: rmdir path
      The `rmdir' function deletes the directory PATH.  The directory
      must be empty before it can be removed.  `rmdir' returns if
      successful, `#f' if not.
 
- - Function: chdir FILENAME
+ - Function: chdir filename
      Changes the current directory to FILENAME.  If FILENAME does not
      exist or is not a directory, `#f' is returned.  Otherwise, `#t' is
      returned.
@@ -3848,33 +4076,33 @@ I/O: (slib)Line I/O, and the following functions are defined:
      name representing the current working directory.  If this string
      cannot be obtained, `#f' is returned.
 
- - Function: rename-file OLDFILENAME NEWFILENAME
+ - Function: rename-file oldfilename newfilename
      Renames the file specified by OLDFILENAME to NEWFILENAME.  If the
      renaming is successful, `#t' is returned.  Otherwise, `#f' is
      returned.
 
- - Function: chmod FILE MODE
+ - Function: chmod file mode
      The function `chmod' sets the access permission bits for the file
      named by FILE to MODE.  The FILE argument may be a string
      containing the filename or a port open to the file.
 
      `chmod' returns if successful, `#f' if not.
 
- - Function: utime PATHNAME ACCTIME MODTIME
+ - Function: utime pathname acctime modtime
      Sets the file times associated with the file named PATHNAME to
      have access time ACCTIME and modification time MODTIME.  `utime'
      returns if successful, `#f' if not.
 
- - Function: umask MODE
+ - Function: umask mode
      The function `umask' sets the file creation mask of the current
      process to MASK, and returns the previous value of the file
      creation mask.
 
- - Function: fileno PORT
+ - Function: fileno port
      Returns the integer file descriptor associated with the port PORT.
      If an error is detected, `#f' is returned.
 
- - Function: access PATHNAME HOW
+ - Function: access pathname how
      Returns `#t' if the file named by PATHNAME can be accessed in the
      way specified by the HOW argument.  The HOW argument can be the
      `logior' of the flags:
@@ -3900,8 +4128,8 @@ I/O: (slib)Line I/O, and the following functions are defined:
     <r>
           File-is-readable?
 
- - Function: execl COMMAND ARG0 ...
- - Function: execlp COMMAND ARG0 ...
+ - Function: execl command arg0 ...
+ - Function: execlp command arg0 ...
      Transfers control to program COMMAND called with arguments ARG0
      ....  For `execl', COMMAND must be an exact pathname of an
      executable file.  `execlp' searches for COMMAND in the list of
@@ -3911,13 +4139,13 @@ I/O: (slib)Line I/O, and the following functions are defined:
      If successful, this procedure does not return.  Otherwise an error
      message is printed and the integer `errno' is returned.
 
- - Function: execv COMMAND ARGLIST
- - Function: execvp COMMAND ARGLIST
+ - Function: execv command arglist
+ - Function: execvp command arglist
      Like `execl' and `execlp' except that the set of arguments to
      COMMAND is ARGLIST.
 
- - Function: putenv STRING
-     adds or removes definitions from the "environment". If the STRING
+ - Function: putenv string
+     adds or removes definitions from the "environment".  If the STRING
      is of the form `NAME=VALUE', the definition is added to the
      environment.  Otherwise, the STRING is interpreted as the name of
      an environment variable, and any definition for this variable in
@@ -3935,32 +4163,40 @@ I/O: (slib)Line I/O, and the following functions are defined:
      (slib)System Interface.).
 
 
-File: scm.info,  Node: Posix Extensions,  Next: Regular Expression Pattern Matching,  Prev: I/O-Extensions,  Up: Packages
-
+File: scm.info,  Node: Posix Extensions,  Next: Unix Extensions,  Prev: I/O-Extensions,  Up: Packages
+                                                                              |
 Posix Extensions
 ================
 
 If `'posix' is provided (by linking in `posix.o'), the following
 functions are defined:
 
- - Function: open-pipe STRING MODES
+ - Function: open-pipe string modes
      If the string MODES contains an <r>, returns an input port capable
      of delivering characters from the standard output of the system
      command STRING.  Otherwise, returns an output port capable of
      receiving characters which become the standard input of the system
      command STRING.  If a pipe cannot be created `#f' is returned.
 
- - Function: open-input-pipe STRING
+ - Function: open-input-pipe string
      Returns an input port capable of delivering characters from the
      standard output of the system command STRING.  If a pipe cannot be
      created `#f' is returned.
 
- - Function: open-output-pipe STRING
+ - Function: open-output-pipe string
      Returns an output port capable of receiving characters which become
      the standard input of the system command STRING.  If a pipe cannot
      be created `#f' is returned.
 
- - Function: close-port PIPE
+ - Function: broken-pipe port                                                 |
+     If this function is defined at top level, it will be called when an      |
+     output pipe is closed from the other side (this is the condition         |
+     under which a SIGPIPE is sent).  The already closed PORT will be         |
+     passed so that any necessary cleanup may be done.  An error is not       |
+     signaled when output to a pipe fails in this way, but any further        |
+     output to the closed pipe will cause an error to be signaled.            |
+                                                                              |
+ - Function: close-port pipe
      Closes the 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.
@@ -3982,6 +4218,11 @@ Persona.
      Returns the process ID of the parent of the current process.  For
      a process's own ID *Note getpid: I/O-Extensions.
 
+ - Function: getlogin                                                         |
+     Returns the (login) name of the user logged in on the controlling        |
+     terminal of the process, or #f if this information cannot be             |
+     determined.                                                              |
+                                                                              |
  - Function: getuid
      Returns the real user ID of this process.
 
@@ -3994,23 +4235,23 @@ Persona.
  - Function: geteuid
      Returns the effective user ID of this process.
 
- - Function: setuid ID
+ - Function: setuid id
      Sets the real user ID of this process to ID.  Returns `#t' if
      successful, `#f' if not.
 
- - Function: setgid ID
+ - Function: setgid id
      Sets the real group ID of this process to ID.  Returns `#t' if
      successful, `#f' if not.
 
- - Function: setegid ID
+ - Function: setegid id
      Sets the effective group ID of this process to ID.  Returns `#t'
      if successful, `#f' if not.
 
- - Function: seteuid ID
+ - Function: seteuid id
      Sets the effective user ID of this process to ID.  Returns `#t' if
      successful, `#f' if not.
 
- - Function: kill PID SIG
+ - Function: kill pid sig
      The `kill' function sends the signal SIGNUM to the process or
      process group specified by PID.  Besides the signals listed in
      *Note Standard Signals: (libc)Standard Signals, SIGNUM can also
@@ -4049,7 +4290,7 @@ Persona.
      There's no way you can tell which of the processes got the signal
      or whether all of them did.
 
- - Function: waitpid PID OPTIONS
+ - Function: waitpid pid options
      The `waitpid' function suspends execution of the current process
      until a child as specified by the PID argument has exited, or
      until a signal is delivered whose action is to terminate the
@@ -4088,12 +4329,14 @@ Persona.
 
        3. Which means both of the above.
 
-     The return value is normally the process ID of the child process
-     whose status is reported.  If the `WNOHANG' option was specified
-     and no child process is waiting to be noticed, the value is zero.
-     A value of `#f' is returned in case of error and `errno' is set.
-     For information about the `errno' codes *Note Process Completion:
-     (GNU C Library)Process Completion.
+     The return value normally is the exit status of the child process,
+     including the exit value along with flags indicating whether a
+     coredump was generated or the child terminated as a result of a
+     signal.  If the `WNOHANG' option was specified and no child
+     process is waiting to be noticed, the value is zero.  A value of
+     `#f' is returned in case of error and `errno' is set.  For
+     information about the `errno' codes *Note Process Completion: (GNU
+     C Library)Process Completion.
 
  - Function: uname
      You can use the `uname' procedure to find out some information
@@ -4116,8 +4359,8 @@ Persona.
           Some examples are `"i386-ANYTHING"', `"m68k-hp"',
           `"sparc-sun"', `"m68k-sun"', `"m68k-sony"' and `"mips-dec"'.
 
- - Function: getpw NAME
- - Function: getpw UID
+ - Function: getpw name
+ - Function: getpw uid
  - Function: getpw
      Returns a vector of information for the entry for `NAME', `UID',
      or the next entry if no argument is given.  The information is:
@@ -4140,15 +4383,15 @@ Persona.
           user logs in, or `#f', indicating that the system default
           should be used.
 
- - Function: setpwent #T
+ - Function: setpwent #t
      Rewinds the pw entry table back to the begining.
 
- - Function: setpwent #F
+ - Function: setpwent #f
  - Function: setpwent
      Closes the pw table.
 
- - Function: getgr NAME
- - Function: getgr UID
+ - Function: getgr name
+ - Function: getgr uid
  - Function: getgr
      Returns a vector of information for the entry for `NAME', `UID',
      or the next entry if no argument is given.  The information is:
@@ -4161,75 +4404,78 @@ Persona.
 
        3. A list of (string) names of users in the group.
 
- - Function: setgrent #T
+ - Function: setgrent #t
      Rewinds the group entry table back to the begining.
 
- - Function: setgrent #F
+ - Function: setgrent #f
  - Function: setgrent
      Closes the group table.
 
  - Function: getgroups
      Returns a vector of all the supplementary group IDs of the process.
 
- - Function: link OLDNAME NEWNAME
+ - Function: link oldname newname
      The `link' function makes a new link to the existing file named by
      OLDNAME, under the new name NEWNAME.
 
      `link' returns a value of `#t' if it is successful and `#f' on
      failure.
 
- - Function: chown FILENAME OWNER GROUP
+ - Function: chown filename owner group
      The `chown' function changes the owner of the file FILENAME to
      OWNER, and its group owner to GROUP.
 
      `chown' returns a value of `#t' if it is successful and `#f' on
      failure.
 
- - Function: ttyname PORT
+ - Function: ttyname port
      If port PORT is associated with a terminal device, returns a
      string containing the file name of termainal device; otherwise
      `#f'.
 
+
+File: scm.info,  Node: Unix Extensions,  Next: Regular Expression Pattern Matching,  Prev: Posix Extensions,  Up: Packages
+                                                                              |
 Unix Extensions
 ===============
 
 If `'unix' is provided (by linking in `unix.o'), the following
 functions are defined:
 
-These "priveledged" and symbolic link functions are not in Posix:
+These "privileged" and symbolic link functions are not in Posix:              |
 
- - Function: symlink OLDNAME NEWNAME
+ - Function: symlink oldname newname
      The `symlink' function makes a symbolic link to OLDNAME named
      NEWNAME.
 
      `symlink' returns a value of `#t' if it is successful and `#f' on
      failure.
 
- - Function: readlink FILENAME
+ - Function: readlink filename
      Returns the value of the symbolic link FILENAME or `#f' for
      failure.
 
- - Function: lstat FILENAME
+ - Function: lstat filename
      The `lstat' function is like `stat', except that it does not
      follow symbolic links.  If FILENAME is the name of a symbolic
      link, `lstat' returns information about the link itself; otherwise,
      `lstat' works like `stat'.  *Note I/O-Extensions::.
 
- - Function: nice INCREMENT
+ - Function: nice increment
      Increment the priority of the current process by INCREMENT.
      `chown' returns a value of `#t' if it is successful and `#f' on
      failure.
 
- - Function: acct FILENAME
+ - Function: acct filename
      When called with the name of an exisitng file as argument,
-     accounting is turned on, records for each terminating pro-cess are
+     accounting is turned on, records for each terminating process are        |
      appended to FILENAME as it terminates.  An argument of `#f' causes
      accounting to be turned off.
 
      `acct' returns a value of `#t' if it is successful and `#f' on
      failure.
 
- - Function: mknod FILENAME MODE DEV
+ - Function: mknod filename mode dev
      The `mknod' function makes a special file with name FILENAME and
      modes MODE for device number DEV.
 
@@ -4242,8 +4488,8 @@ These "priveledged" and symbolic link functions are not in Posix:
      actual writing is done.  The value returned is unspecified.
 
 
-File: scm.info,  Node: Regular Expression Pattern Matching,  Next: Line Editing,  Prev: Posix Extensions,  Up: Packages
-
+File: scm.info,  Node: Regular Expression Pattern Matching,  Next: Line Editing,  Prev: Unix Extensions,  Up: Packages
+                                                                              |
 Regular Expression Pattern Matching
 ===================================
 
@@ -4258,15 +4504,14 @@ description of regular expressions, *Note syntax: (regex)syntax.
      `regerror'.
 
      FLAGS in `regcomp' is a string of option letters used to control
-     the compilation of the regular expression. The letters may consist
-     of:
+     the compilation of the regular expression.  The letters may
+     consist of:
 
     `n'
           newlines won't be matched by `.' or hat lists; ( `[^...]' )
 
     `i'
-          ignore case.
-     only when compiled with _GNU_SOURCE:
+          ignore case.only when compiled with _GNU_SOURCE:
     `0'
           allows dot to match a null character.
 
@@ -4323,14 +4568,14 @@ description of regular expressions, *Note syntax: (regex)syntax.
           The character position at which to begin the search or match.
           If absent, the default is zero.
 
-     *Compiled _GNU_SOURCE and using GNU libregex only:*
+     _Compiled _GNU_SOURCE and using GNU libregex only:_
           When searching, if START is negative, the absolute value of
           START will be used as the start location and reverse searching
           will be performed.
 
     LEN
           The search is allowed to examine only the first LEN
-          characters of STRING. If absent, the entire string may be
+          characters of STRING.  If absent, the entire string may be
           examined.
 
  - Function: string-split RE STRING
@@ -4389,7 +4634,7 @@ line-editing mode will be entered.
  - Function: line-editing
      Returns the current edited line port or `#f'.
 
- - Function: line-editing BOOL
+ - Function: line-editing bool
      If BOOL is false, exits line-editing mode and returns the previous
      value of `(line-editing)'.  If BOOL is true, sets the current
      input and output ports to an edited line port and returns the
@@ -4436,14 +4681,14 @@ These routines set options within curses that deal with output.  All
 options are initially `#f', unless otherwise stated.  It is not
 necessary to turn these options off before calling `endwin'.
 
- - Function: clearok WIN BF
+ - Function: clearok win bf
      If enabled (BF is `#t'), the next call to `force-output' or
      `refresh' with 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.
 
- - Function: idlok WIN BF
+ - Function: idlok win bf
      If enabled (BF is `#t'), curses will consider using the hardware
      "insert/delete-line" feature of terminals so equipped.  If
      disabled (BF is `#f'), curses will very seldom use this feature.
@@ -4457,7 +4702,7 @@ necessary to turn these options off before calling `endwin'.
      "insert/delete-line" cannot be used, curses will redraw the
      changed portions of all lines.
 
- - Function: leaveok WIN BF
+ - Function: 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
@@ -4465,7 +4710,7 @@ necessary to turn these options off before calling `endwin'.
      need for cursor motions.  If possible, the cursor is made
      invisible when this option is enabled.
 
- - Function: scrollok WIN BF
+ - Function: scrollok win bf
      This option controls what happens when the cursor of window 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
@@ -4475,12 +4720,12 @@ necessary to turn these options off before calling `endwin'.
      window WIN, and then the physical terminal and window WIN are
      scrolled up one line.
 
-     *Note:* in order to get the physical scrolling effect on the
+     _Note:_ in order to get the physical scrolling effect on the
      terminal, it is also necessary to call `idlok'.
 
- - Function: nodelay WIN BF
+ - Function: 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
+     is ready, wgetch will return an eof-object.  If disabled, wgetch
      will hang until a key is pressed.
 
 
@@ -4507,7 +4752,7 @@ routines.  It is not necessary to turn these options off before calling
      `cbreak' or `nocbreak' explicitly.  Most interactive programs
      using curses will set `CBREAK' mode.
 
-     *Note:* `cbreak' overrides `raw'.  For a discussion of how these
+     _Note:_ `cbreak' overrides `raw'.  For a discussion of how these
      routines interact with `echo' and `noecho' *Note read-char: Input.
 
  - Function: raw
@@ -4553,14 +4798,14 @@ File: scm.info,  Node: Window Manipulation,  Next: Output,  Prev: Terminal Mode
 Window Manipulation
 -------------------
 
- - Function: newwin NLINES NCOLS BEGY BEGX
+ - Function: newwin nlines ncols begy begx
      Create and return a new window with the given number of lines (or
      rows), NLINES, and columns, NCOLS.  The upper left corner of the
      window is at line BEGY, column BEGX.  If either NLINES or NCOLS is
      0, they will be set to the value of `LINES'-BEGY and `COLS'-BEGX.
      A new full-screen window is created by calling `newwin(0,0,0,0)'.
 
- - Function: subwin ORIG NLINES NCOLS BEGY BEGX
+ - Function: subwin orig nlines ncols begy begx
      Create and return a pointer to a new window with the given number
      of lines (or rows), NLINES, and columns, NCOLS.  The window is at
      position (BEGY, BEGX) on the screen.  This position is relative to
@@ -4570,13 +4815,13 @@ Window Manipulation
      necessary to call `touchwin' or `touchline' on ORIG before calling
      `force-output'.
 
- - Function: close-port WIN
+ - Function: close-port win
      Deletes the window WIN, freeing up all memory associated with it.
      In the case of sub-windows, they should be deleted before the main
      window WIN.
 
  - Function: refresh
- - Function: force-output WIN
+ - Function: force-output win
      These routines are called to write output to the terminal, as most
      other routines merely manipulate data structures.  `force-output'
      copies the window WIN to the physical terminal screen, taking into
@@ -4587,21 +4832,21 @@ Window Manipulation
      `refresh', the number of characters output to the terminal is
      returned.
 
- - Function: mvwin WIN Y X
+ - Function: mvwin win y x
      Move the window WIN so that the upper left corner will be at
      position (Y, X).  If the move would cause the window WIN to be off
      the screen, it is an error and the window WIN is not moved.
 
- - Function: overlay SRCWIN DSTWIN
- - Function: overwrite SRCWIN DSTWIN
+ - Function: overlay srcwin dstwin
+ - Function: overwrite srcwin dstwin
      These routines overlay SRCWIN on top of DSTWIN; that is, all text
      in SRCWIN is copied into DSTWIN.  SRCWIN and DSTWIN need not be
      the same size; only text where the two windows overlap is copied.
      The difference is that `overlay' is non-destructive (blanks are
      not copied), while `overwrite' is destructive.
 
- - Function: touchwin WIN
- - Function: touchline WIN START COUNT
+ - Function: touchwin win
+ - Function: touchline win start count
      Throw away all optimization information about which parts of the
      window WIN have been touched, by pretending that the entire window
      WIN has been drawn on.  This is sometimes necessary when using
@@ -4611,7 +4856,7 @@ Window Manipulation
      pretends that COUNT lines have been changed, beginning with line
      START.
 
- - Function: wmove WIN Y X
+ - Function: wmove win y x
      The cursor associated with the window WIN is moved to line (row) Y,
      column X.  This does not move the physical cursor of the terminal
      until `refresh' (or `force-output') is called.  The position
@@ -4626,10 +4871,10 @@ Output
 
 These routines are used to "draw" text on windows
 
- - Function: display CH WIN
- - Function: display STR WIN
- - Function: wadd WIN CH
- - Function: wadd WIN STR
+ - Function: display ch win
+ - Function: display str win
+ - Function: wadd win ch
+ - Function: wadd win str
      The character CH or characters in STR are put into the window WIN
      at the current cursor position of the window and the position of
      WIN's cursor is advanced.  At the right margin, an automatic
@@ -4652,51 +4897,51 @@ These routines are used to "draw" text on windows
      can be copied from one place to another using inch and display.
      See `standout', below.
 
-     *Note:* For `wadd' CH can be an integer and will insert the
+     _Note:_ For `wadd' CH can be an integer and will insert the
      character of the corresponding value.
 
- - Function: werase WIN
+ - Function: werase win
      This routine copies blanks to every position in the window WIN.
 
- - Function: wclear WIN
+ - Function: wclear win
      This routine is like `werase', but it also calls *Note clearok:
      Output Options Setting, arranging that the screen will be cleared
      completely on the next call to `refresh' or `force-output' for
      window WIN, and repainted from scratch.
 
- - Function: wclrtobot WIN
+ - Function: wclrtobot win
      All lines below the cursor in window WIN are erased.  Also, the
      current line to the right of the cursor, inclusive, is erased.
 
- - Function: wclrtoeol WIN
+ - Function: wclrtoeol win
      The current line to the right of the cursor, inclusive, is erased.
 
- - Function: wdelch WIN
+ - Function: wdelch win
      The character under the cursor in the window 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.
 
- - Function: wdeleteln WIN
+ - Function: wdeleteln win
      The line under the cursor in the window WIN is deleted.  All lines
      below the current line are moved up one line.  The bottom line WIN
      is cleared.  The cursor position does not change.  This does not
      imply use of the hardware "deleteline" feature.
 
- - Function: winsch WIN CH
+ - Function: winsch win ch
      The character CH is inserted before the character under the
      cursor.  All characters to the right are moved one <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.
 
- - Function: winsertln WIN
+ - Function: 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.
 
- - Function: scroll WIN
+ - Function: scroll win
      The window WIN is scrolled up one line.  This involves moving the
      lines in WIN's data structure.  As an optimization, if WIN is
      stdscr and the scrolling region is the entire window, the physical
@@ -4708,7 +4953,7 @@ File: scm.info,  Node: Input,  Next: Curses Miscellany,  Prev: Output,  Up: Curs
 Input
 -----
 
- - Function: read-char WIN
+ - Function: read-char win
      A character is read from the terminal associated with the window
      WIN.  Depending on the setting of `cbreak', this will be after one
      character (`CBREAK' mode), or after the first newline (`NOCBREAK'
@@ -4720,12 +4965,12 @@ Input
      on the state of the terminal driver when each character is typed,
      the program may produce undesirable results.
 
- - Function: winch WIN
+ - Function: winch win
      The character, of type chtype, at the current position in window
      WIN is returned.  If any attributes are set for that position,
      their values will be OR'ed into the value returned.
 
- - Function: getyx WIN
+ - Function: getyx win
      A list of the y and x coordinates of the cursor position of the
      window WIN is returned
 
@@ -4735,8 +4980,8 @@ File: scm.info,  Node: Curses Miscellany,  Prev: Input,  Up: Curses
 Curses Miscellany
 -----------------
 
- - Function: wstandout WIN
- - Function: wstandend WIN
+ - Function: wstandout win
+ - Function: wstandend win
      These functions set the current attributes of the window WIN.  The
      current attributes of WIN are applied to all characters that are
      written into it.  Attributes are a property of the character, and
@@ -4749,16 +4994,16 @@ Curses Miscellany
      visibly different from other text.  `wstandend' turns off the
      attributes.
 
- - Function: box WIN VERTCH HORCH
+ - Function: box win vertch horch
      A box is drawn around the edge of the window WIN.  VERTCH and
      HORCH are the characters the box is to be drawn with.  If VERTCH
      and HORCH are 0, then appropriate default characters, `ACS_VLINE'
      and `ACS_HLINE', will be used.
 
-     *Note:* VERTCH and HORCH can be an integers and will insert the
+     _Note:_ VERTCH and HORCH can be an integers and will insert the
      character (with attributes) of the corresponding values.
 
- - Function: unctrl C
+ - Function: unctrl c
      This macro expands to a character string which is a printable
      representation of the character C.  Control characters are
      displayed in the `C-x' notation.  Printing characters are displayed
@@ -4790,7 +5035,7 @@ Host Data, Network, Protocol, and Service Inquiries
  - Constant: af_unix
      Integer family codes for Internet and Unix sockets, respectively.
 
- - Function: gethost HOST-SPEC
+ - Function: gethost host-spec
  - Function: gethost
      Returns a vector of information for the entry for `HOST-SPEC' or
      the next entry if `HOST-SPEC' isn't given.  The information is:
@@ -4805,7 +5050,7 @@ Host Data, Network, Protocol, and Service Inquiries
 
        4. list of integer addresses
 
- - Function: sethostent STAY-OPEN
+ - Function: sethostent stay-open
  - Function: sethostent
      Rewinds the host entry table back to the begining if given an
      argument.  If the argument STAY-OPEN is `#f' queries will be be
@@ -4813,7 +5058,7 @@ Host Data, Network, Protocol, and Service Inquiries
      will be used.  When called without an argument, the host table is
      closed.
 
- - Function: getnet NAME-OR-NUMBER
+ - Function: getnet name-or-number
  - Function: getnet
      Returns a vector of information for the entry for NAME-OR-NUMBER or
      the next entry if an argument isn't given.  The information is:
@@ -4826,14 +5071,14 @@ Host Data, Network, Protocol, and Service Inquiries
 
        3. integer network number
 
- - Function: setnetent STAY-OPEN
+ - Function: setnetent stay-open
  - Function: setnetent
      Rewinds the network entry table back to the begining if given an
      argument.  If the argument STAY-OPEN is `#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.
 
- - Function: getproto NAME-OR-NUMBER
+ - Function: getproto name-or-number
  - Function: getproto
      Returns a vector of information for the entry for NAME-OR-NUMBER or
      the next entry if an argument isn't given.  The information is:
@@ -4844,7 +5089,7 @@ Host Data, Network, Protocol, and Service Inquiries
 
        3. integer protocol number
 
- - Function: setprotoent STAY-OPEN
+ - Function: setprotoent stay-open
  - Function: setprotoent
      Rewinds the protocol entry table back to the begining if given an
      argument.  If the argument STAY-OPEN is `#f' the table will be
@@ -4852,7 +5097,7 @@ Host Data, Network, Protocol, and Service Inquiries
      open.  When called without an argument, the protocol table is
      closed.
 
- - Function: getserv NAME-OR-PORT-NUMBER PROTOCOL
+ - Function: getserv name-or-port-number protocol
  - Function: getserv
      Returns a vector of information for the entry for
      NAME-OR-PORT-NUMBER and PROTOCOL or the next entry if arguments
@@ -4866,7 +5111,7 @@ Host Data, Network, Protocol, and Service Inquiries
 
        3. protocol
 
- - Function: setservent STAY-OPEN
+ - Function: setservent stay-open
  - Function: setservent
      Rewinds the service entry table back to the begining if given an
      argument.  If the argument STAY-OPEN is `#f' the table will be
@@ -4879,43 +5124,43 @@ File: scm.info,  Node: Internet Addresses and Socket Names,  Next: Socket,  Prev
 Internet Addresses and Socket Names
 -----------------------------------
 
- - Function: inet:string->address STRING
+ - Function: inet:string->address string
      Returns the host address number (integer) for host STRING or `#f'
      if not found.
 
- - Function: inet:address->string ADDRESS
+ - Function: inet:address->string address
      Converts an internet (integer) address to a string in numbers and
      dots notation.
 
- - Function: inet:network ADDRESS
+ - Function: inet:network address
      Returns the network number (integer) specified from ADDRESS or
      `#f' if not found.
 
- - Function: inet:local-network-address ADDRESS
+ - Function: inet:local-network-address address
      Returns the integer for the address of ADDRESS within its local
      network or `#f' if not found.
 
- - Function: inet:make-address NETWORK LOCAL-ADDRESS
+ - Function: inet:make-address network local-address
      Returns the Internet address of LOCAL-ADDRESS in NETWORK.
 
 The type "socket-name" is used for inquiries about open sockets in the
 following procedures:
 
- - Function: getsockname SOCKET
+ - Function: getsockname socket
      Returns the socket-name of SOCKET.  Returns `#f' if unsuccessful
      or SOCKET is closed.
 
- - Function: getpeername SOCKET
+ - Function: getpeername socket
      Returns the socket-name of the socket connected to SOCKET.
      Returns `#f' if unsuccessful or SOCKET is closed.
 
- - Function: socket-name:family SOCKET-NAME
+ - Function: socket-name:family socket-name
      Returns the integer code for the family of SOCKET-NAME.
 
- - Function: socket-name:port-number SOCKET-NAME
+ - Function: socket-name:port-number socket-name
      Returns the integer port number of SOCKET-NAME.
 
- - Function: socket-name:address SOCKET-NAME
+ - Function: socket-name:address socket-name
      Returns the integer Internet address for SOCKET-NAME.
 
 
@@ -4931,8 +5176,8 @@ buffered ports you can (assuming sock-port is a socket i/o port):
      (define i-port (duplicate-port sock-port "r"))
      (define o-port (duplicate-port sock-port "w"))
 
- - Function: make-stream-socket FAMILY
- - Function: make-stream-socket FAMILY PROTOCOL
+ - Function: make-stream-socket family
+ - Function: make-stream-socket family protocol
      Returns a `SOCK_STREAM' socket of type FAMILY using PROTOCOL.  If
      FAMILY has the value `AF_INET', `SO_REUSEADDR' will be set.  The
      integer argument PROTOCOL corresponds to the integer protocol
@@ -4941,8 +5186,8 @@ buffered ports you can (assuming sock-port is a socket i/o port):
      specified FAMILY is used.  SCM sockets look like ports opened for
      neither reading nor writing.
 
- - Function: make-stream-socketpair FAMILY
- - Function: make-stream-socketpair FAMILY PROTOCOL
+ - Function: make-stream-socketpair family
+ - Function: make-stream-socketpair family protocol
      Returns a pair (cons) of connected `SOCK_STREAM' (socket) ports of
      type FAMILY using PROTOCOL.  Many systems support only socketpairs
      of the `af-unix' FAMILY.  The integer argument PROTOCOL
@@ -4950,7 +5195,7 @@ buffered ports you can (assuming sock-port is a socket i/o port):
      elements) from (getproto).  If the PROTOCOL argument is not
      supplied, the default (0) for the specified FAMILY is used.
 
- - Function: socket:shutdown SOCKET HOW
+ - Function: socket:shutdown socket how
      Makes SOCKET no longer respond to some or all operations depending
      on the integer argument HOW:
 
@@ -4962,34 +5207,34 @@ buffered ports you can (assuming sock-port is a socket i/o port):
 
      `Socket:shutdown' returns SOCKET if successful, `#f' if not.
 
- - Function: socket:connect INET-SOCKET HOST-NUMBER PORT-NUMBER
- - Function: socket:connect UNIX-SOCKET PATHNAME
+ - Function: socket:connect inet-socket host-number port-number
+ - Function: socket:connect unix-socket pathname
      Returns SOCKET (changed to a read/write port) connected to the
      Internet socket on host HOST-NUMBER, port PORT-NUMBER or the Unix
      socket specified by PATHNAME.  Returns `#f' if not successful.
 
- - Function: socket:bind INET-SOCKET PORT-NUMBER
- - Function: socket:bind UNIX-SOCKET PATHNAME
+ - Function: socket:bind inet-socket port-number
+ - Function: socket:bind unix-socket pathname
      Returns INET-SOCKET bound to the integer PORT-NUMBER or the
      UNIX-SOCKET bound to new socket in the file system at location
-     PATHNAME.  Returns `#f' if not successful. Binding a UNIX-SOCKET
+     PATHNAME.  Returns `#f' if not successful.  Binding a UNIX-SOCKET
      creates a socket in the file system that must be deleted by the
      caller when it is no longer needed (using `delete-file').
 
- - Function: socket:listen SOCKET BACKLOG
+ - Function: socket:listen socket backlog
      The bound (*note bind: Socket.) SOCKET is readied to accept
      connections.  The positive integer BACKLOG specifies how many
      pending connections will be allowed before further connection
      requests are refused.  Returns SOCKET (changed to a read-only
      port) if successful, `#f' if not.
 
- - Function: char-ready? LISTEN-SOCKET
+ - Function: char-ready? listen-socket
      The input port returned by a successful call to `socket:listen' can
      be polled for connections by `char-ready?' (*note char-ready?:
      Files and Ports.).  This avoids blocking on connections by
      `socket:accept'.
 
- - Function: socket:accept SOCKET
+ - Function: socket:accept socket
      Accepts a connection on a bound, listening SOCKET.  Returns an
      input/output port for the connection.
 
@@ -5124,8 +5369,8 @@ An "immediate" is a data type contained in type `SCM' (`long int').
 The type codes distinguishing immediate types from each other vary in
 length, but reside in the low order bits.
 
- - Macro: IMP X
- - Macro: NIMP X
+ - Macro: IMP x
+ - Macro: NIMP x
      Return non-zero if the `SCM' object X is an immediate or
      non-immediate type, respectively.
 
@@ -5134,15 +5379,15 @@ length, but reside in the low order bits.
      the second to low order bit position.  The high order 30 bits are
      used for the integer's value.
 
-      - Macro: INUMP X
-      - Macro: NINUMP X
+      - Macro: INUMP x
+      - Macro: NINUMP x
           Return non-zero if the `SCM' X is an immediate integer or not
           an immediate integer, respectively.
 
-      - Macro: INUM X
+      - Macro: INUM x
           Returns the C `long integer' corresponding to `SCM' X.
 
-      - Macro: MAKINUM X
+      - Macro: MAKINUM x
           Returns the `SCM' inum corresponding to C `long integer' x.
 
       - Immediate Constant: INUM0
@@ -5161,13 +5406,13 @@ length, but reside in the low order bits.
  - Immediate: ichr
      characters.
 
-      - Macro: ICHRP X
+      - Macro: ICHRP x
           Return non-zero if the `SCM' object X is a character.
 
-      - Macro: ICHR X
+      - Macro: ICHR x
           Returns corresponding `unsigned char'.
 
-      - Macro: MAKICHR X
+      - Macro: MAKICHR x
           Given `char' X, returns `SCM' character.
 
 
@@ -5196,27 +5441,27 @@ length, but reside in the low order bits.
           values are not specified.
 
 
- - Macro: IFLAGP N
+ - Macro: IFLAGP n
      Returns non-zero if N is an ispcsym, isym or iflag.
 
- - Macro: ISYMP N
+ - Macro: ISYMP n
      Returns non-zero if N is an ispcsym or isym.
 
- - Macro: ISYMNUM N
+ - Macro: ISYMNUM n
      Given ispcsym, isym, or iflag N, returns its index in the C array
      `isymnames[]'.
 
- - Macro: ISYMCHARS N
+ - Macro: ISYMCHARS n
      Given ispcsym, isym, or iflag N, returns its `char *'
      representation (from `isymnames[]').
 
- - Macro: MAKSPCSYM N
+ - Macro: MAKSPCSYM n
      Returns `SCM' ispcsym N.
 
- - Macro: MAKISYM N
+ - Macro: MAKISYM n
      Returns `SCM' iisym N.
 
- - Macro: MAKIFLAG N
+ - Macro: MAKIFLAG n
      Returns `SCM' iflag N.
 
  - Variable: isymnames
@@ -5247,7 +5492,7 @@ length, but reside in the low order bits.
      completeness).  Since cells are always 8 byte aligned, a pointer
      to a cell has the low order 3 bits `0'.
 
-     There is one exception to this rule, *CAR Immediate*s, described
+     There is one exception to this rule, _CAR Immediate_s, described
      next.
 
 A "CAR Immediate" is an Immediate point which can only occur in the
@@ -5265,7 +5510,7 @@ object.  The rest of `CAR' and `CDR' hold object data.  The number
 after `tc' specifies how many bits are in the type code.  For instance,
 `tc7' indicates that the type code is 7 bits.
 
- - Macro: NEWCELL X
+ - Macro: NEWCELL x
      Allocates a new cell and stores a pointer to it in `SCM' local
      variable X.
 
@@ -5275,20 +5520,20 @@ after `tc' specifies how many bits are in the type code.  For instance,
 All of the C macros decribed in this section assume that their argument
 is of type `SCM' and points to a cell (`CELLPTR').
 
- - Macro: CAR X
- - Macro: CDR X
+ - Macro: CAR x
+ - Macro: CDR x
      Returns the `car' and `cdr' of cell X, respectively.
 
- - Macro: TYP3 X
- - Macro: TYP7 X
- - Macro: TYP16 X
+ - Macro: TYP3 x
+ - Macro: TYP7 x
+ - Macro: TYP16 x
      Returns the 3, 7, and 16 bit type code of a cell.
 
  - Cell: tc3_cons
      scheme cons-cell returned by (cons arg1 arg2).
 
-      - Macro: CONSP X
-      - Macro: NCONSP X
+      - Macro: CONSP x
+      - Macro: NCONSP x
           Returns non-zero if X is a `tc3_cons' or isn't, respectively.
 
  - Cell: tc3_closure
@@ -5301,15 +5546,15 @@ is of type `SCM' and points to a cell (`CELLPTR').
      encoding precludes an immediate value for the `CDR':  In the case
      of an empty environment all bits above 2 in the `CDR' are zero.
 
-      - Macro: CLOSUREP X
+      - Macro: CLOSUREP x
           Returns non-zero if X is a `tc3_closure'.
 
-      - Macro: CODE X
-      - Macro: ENV X
+      - Macro: CODE x
+      - Macro: ENV x
           Returns the code body or environment of closure X,
           respectively.
 
-      - Macro: ARGC X
+      - Macro: ARGC x
           Returns the a lower bound on the number of required arguments
           to closure X, it cannot exceed 3.
 
@@ -5329,13 +5574,13 @@ memory allocated by `malloc'.
  - Header: tc7_vector
      scheme vector.
 
-      - Macro: VECTORP X
-      - Macro: NVECTORP X
+      - Macro: VECTORP x
+      - Macro: NVECTORP x
           Returns non-zero if X is a `tc7_vector' or if not,
           respectively.
 
-      - Macro: VELTS X
-      - Macro: LENGTH X
+      - Macro: VELTS x
+      - Macro: LENGTH x
           Returns the C array of `SCM's holding the elements of vector
           X or its length, respectively.
 
@@ -5345,26 +5590,26 @@ memory allocated by `malloc'.
  - Header: tc7_msymbol
      `malloc'ed scheme symbol (can be GCed)
 
-      - Macro: SYMBOLP X
+      - Macro: SYMBOLP x
           Returns non-zero if X is a `tc7_ssymbol' or `tc7_msymbol'.
 
-      - Macro: CHARS X
-      - Macro: UCHARS X
-      - Macro: LENGTH X
+      - Macro: CHARS x
+      - Macro: UCHARS x
+      - Macro: LENGTH x
           Returns the C array of `char's or as `unsigned char's holding
           the elements of symbol X or its length, respectively.
 
  - Header: tc7_string
      scheme string
 
-      - Macro: STRINGP X
-      - Macro: NSTRINGP X
+      - Macro: STRINGP x
+      - Macro: NSTRINGP x
           Returns non-zero if X is a `tc7_string' or isn't,
           respectively.
 
-      - Macro: CHARS X
-      - Macro: UCHARS X
-      - Macro: LENGTH X
+      - Macro: CHARS x
+      - Macro: UCHARS x
+      - Macro: LENGTH x
           Returns the C array of `char's or as `unsigned char's holding
           the elements of string X or its length, respectively.
 
@@ -5377,6 +5622,9 @@ memory allocated by `malloc'.
  - Header: tc7_uvect
      uniform vector of non-negative integers
 
+ - Header: tc7_svect                                                          |
+     uniform vector of short integers                                         |
+                                                                              |
  - Header: tc7_fvect
      uniform vector of short inexact real numbers
 
@@ -5406,12 +5654,12 @@ memory allocated by `malloc'.
           invocation is currently not tail recursive when given 2 or
           more arguments.
 
-      - Function: makcclo PROC LEN
-          makes a closure from the *subr* PROC with LEN-1 extra
+      - Function: makcclo proc len
+          makes a closure from the _subr_ PROC with LEN-1 extra
           locations for `SCM' data.  Elements of a CCLO are referenced
           using `VELTS(cclo)[n]' just as for vectors.
 
-      - Macro: CCLO_LENGTH CCLO
+      - Macro: CCLO_LENGTH cclo
           Expands to the length of CCLO.
 
 
@@ -5487,7 +5735,7 @@ Ptob Cells
 A "ptob" is a port object, capable of delivering or accepting
 characters.  *Note Ports: (r5rs)Ports.  Unlike the types described so
 far, new varieties of ptobs can be defined dynamically (*note Defining
-Ptobs::.).  These are the initial ptobs:
+Ptobs::).  These are the initial ptobs:
 
  - ptob: tc16_inport
      input port.
@@ -5508,33 +5756,32 @@ Ptobs::.).  These are the initial ptobs:
      String port created by `cwos()' or `cwis()'.
 
  - ptob: tc16_sfport
-     Software (virtual) port created by `mksfpt()' (*note Soft
-     Ports::.).
-
- - Macro: PORTP X
- - Macro: OPPORTP X
- - Macro: OPINPORTP X
- - Macro: OPOUTPORTP X
- - Macro: INPORTP X
- - Macro: OUTPORTP X
+     Software (virtual) port created by `mksfpt()' (*note Soft Ports::).
+
+ - Macro: PORTP x
+ - Macro: OPPORTP x
+ - Macro: OPINPORTP x
+ - Macro: OPOUTPORTP x
+ - Macro: INPORTP x
+ - Macro: OUTPORTP x
      Returns non-zero if X is a port, open port, open input-port, open
      output-port, input-port, or output-port, respectively.
 
- - Macro: OPENP X
- - Macro: CLOSEDP X
+ - Macro: OPENP x
+ - Macro: CLOSEDP x
      Returns non-zero if port X is open or closed, respectively.
 
- - Macro: STREAM X
+ - Macro: STREAM x
      Returns the `FILE *' stream for port X.
 
 Ports which are particularly well behaved are called "fport"s.
 Advanced operations like `file-position' and `reopen-file' only work
 for fports.
 
- - Macro: FPORTP X
- - Macro: OPFPORTP X
- - Macro: OPINFPORTP X
- - Macro: OPOUTFPORTP X
+ - Macro: FPORTP x
+ - Macro: OPFPORTP x
+ - Macro: OPINFPORTP x
+ - Macro: OPOUTFPORTP x
      Returns non-zero if X is a port, open port, open input-port, or
      open output-port, respectively.
 
@@ -5550,7 +5797,7 @@ of the `CAR' can be used for sub-type or other information.  The `CDR'
 contains data of size long and is often a pointer to allocated memory.
 
 Like ptobs, new varieties of smobs can be defined dynamically (*note
-Defining Smobs::.).  These are the initial smobs:
+Defining Smobs::).  These are the initial smobs:
 
  - smob: tc_free_cell
      unused cell on the freelist.
@@ -5590,7 +5837,7 @@ Defining Smobs::.).  These are the initial smobs:
 
      Why only 4800 digits?  The simple multiplication algorithm SCM
      uses is O(n^2); this means the number of processor instructions
-     required to perform a multiplication is *some multiple* of the
+     required to perform a multiplication is _some multiple_ of the
      product of the number of digits of the two multiplicands.
 
           digits * digits  ==> operations
@@ -5604,7 +5851,7 @@ Defining Smobs::.).  These are the initial smobs:
      should obtain a package which specializes in number-theoretical
      calculations:
 
-                `ftp://megrez.math.u-bordeaux.fr/pub/pari/'
+                <ftp://megrez.math.u-bordeaux.fr/pub/pari/>
 
 
  - smob: tc16_promise
@@ -5620,9 +5867,9 @@ Defining Smobs::.).  These are the initial smobs:
      multi-dimensional array.  *Note Arrays::.
 
      This type implements both conventional arrays (those with
-     arbitrary data as elements *note Conventional Arrays::.) and
+     arbitrary data as elements *note Conventional Arrays::) and
      uniform arrays (those with elements of a uniform type *note
-     Uniform Array::.).
+     Uniform Array::).
 
      Conventional Arrays have a pointer to a vector for their `CDR'.
      Uniform Arrays have a pointer to a Uniform Vector type (string,
@@ -5661,7 +5908,7 @@ bvect   .........long length....G0010101  ..........long *words...........
 ivect   .........long length....G0011101  ..........long *words...........
 uvect   .........long length....G0011111  ......unsigned long *words......
  spare                          G0100101
- spare                          G0100111
+svect   .........long length....G0100111  ........ short *words...........    |
 fvect   .........long length....G0101101  .........float *words...........
 dvect   .........long length....G0101111  ........double *words...........
 cvect   .........long length....G0110101  ........double *words...........
@@ -5765,11 +6012,11 @@ during garbage collection.  Special C macros are defined in `scm.h' to
 allow easy manipulation when GC bits are possibly set.  `CAR', `TYP3',
 and `TYP7' can be used on GC marked cells as they are.
 
- - Macro: GCCDR X
+ - Macro: GCCDR x
      Returns the CDR of a cons cell, even if that cell has been GC
      marked.
 
- - Macro: GCTYP16 X
+ - Macro: GCTYP16 x
      Returns the 16 bit type code of a cell.
 
 We need to (recursively) mark only a few objects in order to assure that
@@ -5837,7 +6084,7 @@ optimize the allocation and garbage collection of environments.
 The optimizations are based on certain facts and assumptions:
 
 The SCM evaluator creates many environments with short lifetimes and
-these account of a *large portion* of the total number of objects
+these account of a _large portion_ of the total number of objects
 allocated.
 
 The general purpose allocator allocates objects from a freelist, and
@@ -5933,8 +6180,8 @@ Signals
      handlers immediately reestablish themselves by a call to
      `signal()'.
 
- - Function: int_signal SIG
- - Function: alrm_signal SIG
+ - Function: int_signal sig
+ - Function: alrm_signal sig
      The low level handlers for `SIGINT' and `SIGALRM'.
 
 If an interrupt handler is defined when the interrupt is received, the
@@ -5968,7 +6215,7 @@ File: scm.info,  Node: C Macros,  Next: Changing Scm,  Prev: Signals,  Up: Opera
 C Macros
 --------
 
- - Macro: ASSERT COND ARG POS SUBR
+ - Macro: ASSERT cond arg pos subr
      signals an error if the expression (COND) is 0.  ARG is the
      offending object, SUBR is the string naming the subr, and POS
      indicates the position or type of error.  POS can be one of
@@ -6013,7 +6260,7 @@ C Macros
      defined.  An error condition can still be signaled in this case
      with a call to `wta(arg, pos, subr)'.
 
- - Macro: ASRTGO COND LABEL
+ - Macro: ASRTGO cond label
      `goto' LABEL if the expression (COND) is 0.  Like `ASSERT',
      `ASRTGO' does is not active if the flag `RECKLESS' is defined.
 
@@ -6024,7 +6271,7 @@ Changing Scm
 ------------
 
 When writing C-code for SCM, a precaution is recommended.  If your
-routine allocates a non-cons cell which will *not* be incorporated into
+routine allocates a non-cons cell which will _not_ be incorporated into
 a `SCM' object which is returned, you need to make sure that a `SCM'
 variable in your routine points to that cell as long as part of it
 might be referenced by your code.
@@ -6039,7 +6286,7 @@ or put this assignment somewhere in your routine:
      SCM_dummy1 = (SCM) &foo;
 
 `SCM_dummy' variables are not currently defined.  Passing the address
-of the local `SCM' variable to *any* procedure also protects it.  The
+of the local `SCM' variable to _any_ procedure also protects it.  The
 procedure `scm_protect_temp' is provided for this purpose.
 
 Also, if you maintain a static pointer to some (non-immediate) `SCM'
@@ -6106,7 +6353,7 @@ To add a package of new procedures to scm (see `crs.c' for example):
   7. put any scheme code which needs to be run as part of your package
      into `Ifoo.scm'.
 
-  8. put an `if' into `Init5d2.scm' which loads `Ifoo.scm' if your            |
+  8. put an `if' into `Init5d6.scm' which loads `Ifoo.scm' if your            |
      package is included:
 
           (if (defined? twiddle-bits!)
@@ -6120,7 +6367,7 @@ To add a package of new procedures to scm (see `crs.c' for example):
   9. put documentation of the new procedures into `foo.doc'
 
  10. add lines to your `Makefile' to compile and link SCM with your
-     object file.  Add a `init_foo\(\)\;' to the `INITS=...'  line at
+     object file.  Add a `init_foo\(\)\;' to the `INITS=...' line at
      the beginning of the makefile.
 
 These steps should allow your package to be linked into SCM with a
@@ -6154,7 +6401,7 @@ The SCM interpreter directly recognizes subrs taking small numbers of
 arguments.  In order to create subrs taking larger numbers of arguments
 use:
 
- - Function: make_gsubr NAME REQ OPT REST FCN
+ - Function: make_gsubr name req opt rest fcn
      returns a cclo (compiled closure) object of name `char *' NAME
      which takes `int' REQ required arguments, `int' OPT optional
      arguments, and a list of rest arguments if `int' REST is 1 (0 for
@@ -6221,7 +6468,7 @@ following lines need to be added to your code:
           mark) and returns type `SCM' which will then be marked.  If
           no further objects need to be marked then return an immediate
           object such as `BOOL_F'.  The smob cell itself will already
-          have been marked.  *Note:* This is different from SCM
+          have been marked.  _Note:_ This is different from SCM
           versions prior to 5c5.  Only additional data specific to a
           smob type need be marked by `smob.mark'.
 
@@ -6247,9 +6494,10 @@ following lines need to be added to your code:
           is the smob object.  The second, of type `SCM', is the stream
           on which to write the result.  The third, of type int, is 1
           if the object should be `write'n, 0 if it should be
-          `display'ed.  This function should return non-zero if it
-          printed, and zero otherwise (in which case a hexadecimal
-          number will be printed).
+          `display'ed, and 2 if it should be `write'n for an error            |
+          report.  This function should return non-zero if it printed,        |
+          and zero otherwise (in which case a hexadecimal number will         |
+          be printed).                                                        |
 
     `smob.equalp'
           is 0 or a function of 2 `SCM' arguments.  Both of these
@@ -6314,7 +6562,7 @@ following functions are provided for that purpose:
  - Function: char * must_malloc (long LEN, char *WHAT)
      LEN is the number of bytes that should be allocated, WHAT is a
      string to be used in error or gc messages.  `must_malloc' returns
-     a pointer to newly allocated memory. `must_malloc_cell' returns a
+     a pointer to newly allocated memory.  `must_malloc_cell' returns a
      newly allocated cell whose `car' is C and whose `cdr' is a pointer
      to newly allocated memory.
 
@@ -6329,14 +6577,16 @@ following functions are provided for that purpose:
      address of a block of memory of length OLEN allocated by
      `must_malloc' and returns the address of a block of length LEN.
 
-     The contents of the reallocated block will be unchanged up the the
+     The contents of the reallocated block will be unchanged up to the
      minimum of the old and new sizes.
 
      WHAT is a pointer to a string used for error and gc messages.
 
 `must_malloc', `must_malloc_cell', `must_realloc', and
 `must_realloc_cell' must be called with interrupts deferred *Note
-Signals::.
+Signals::.  `must_realloc' and `must_realloc_cell' must not be called         |
+during initialization (non-zero errjmp_bad) - the initial allocations         |
+must be large enough.                                                         |
 
  - Function: void must_free (char *PTR, sizet LEN)
      `must_free' is used to free a block of memory allocated by the
@@ -6366,8 +6616,8 @@ module.
  - Variable: char *execpath
      This string is the pathname of the executable file being run.  This
      variable can be examined and set from Scheme (*note Internal
-     State::.).  EXECPATH must be set to executable's path in order to
-     use DUMP (*note Dump::.) or DLD.
+     State::).  EXECPATH must be set to executable's path in order to
+     use DUMP (*note Dump::) or DLD.
 
 Rename main() and arrange your code to call it with an ARGV which sets
 up SCM as you want it.
@@ -6382,7 +6632,7 @@ descriptions of the functions which main() calls.
  - Function: char * scm_find_execpath (int ARGC, char **ARGV, char
           *SCRIPT_ARG)
      ARGC and ARGV are as described in main().  SCRIPT_ARG is the
-     pathname of the SCSH-style script (*note Scripting::.) being
+     pathname of the SCSH-style script (*note Scripting::) being
      invoked; 0 otherwise.  `scm_find_execpath' returns the pathname of
      the executable being run; if `scm_find_execpath' cannot determine
      the pathname, then it returns 0.
@@ -6403,7 +6653,7 @@ SCM, then you can replace `scm_find_implpath'.
      environment variable is defined, its value will be returned from
      `scm_find_implpath'.  Otherwise find_impl_file() is called with the
      arguments EXECPATH, GENERIC_NAME (default "scm"), INIT_FILE_NAME
-     (default "Init5d2_scm"), and the directory separator string              |
+     (default "Init5d6_scm"), and the directory separator string              |
      DIRSEP.  If find_impl_file() returns 0 and IMPLINIT is defined,
      then a copy of the string IMPLINIT is returned.
 
@@ -6468,7 +6718,7 @@ handle interrupts and signals.
 
 You can call indivdual Scheme procedures from C code in the TOPLVL_FUN
 argument passed to scm_top_level(), or from module subrs (registered by
-an `init_' function, *note Changing Scm::.).
+an `init_' function, *note Changing Scm::).
 
 Use `apply' to call Scheme procedures from your C code.  For example:
 
@@ -6481,7 +6731,7 @@ Use `apply' to call Scheme procedures from your C code.  For example:
      retval = apply(func, cons(mksproc(srvproc), args), EOL);
 
 Functions for loading Scheme files and evaluating Scheme code given as
-C strings are described in the next section, (*note Callbacks::.).
+C strings are described in the next section, (*note Callbacks::).
 
 Here is a minimal embedding program `libtest.c':
 
@@ -6515,7 +6765,7 @@ Here is a minimal embedding program `libtest.c':
        fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath);
        implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep);
        fprintf(stderr, "implpath: %s\n", implpath);
-       scm_init_from_argv(argc, argv, 0, 0);
+       scm_init_from_argv(argc, argv, 0L, 0, 0);
      
        retval = scm_top_level(implpath, user_main);
      
@@ -6525,7 +6775,7 @@ Here is a minimal embedding program `libtest.c':
      
      -|
      dld_find_executable(./libtest): /home/jaffer/scm/libtest
-     implpath: /home/jaffer/scm/Init5d2.scm                                   |
+     implpath: /home/jaffer/scm/Init5d6.scm                                   |
      This is init_user_scm
      hello world
 
@@ -6541,7 +6791,7 @@ The source code for these routines are found in `rope.c'.
  - Function: int scm_ldfile (char *FILE)
      Loads the Scheme source file FILE.  Returns 0 if successful, non-0
      if not.  This function is used to load SCM's initialization file
-     `Init5d2.scm'.                                                           |
+     `Init5d6.scm'.                                                           |
 
  - Function: int scm_ldprog (char *FILE)
      Loads the Scheme source file `(in-vicinity (program-vicinity)
@@ -6610,7 +6860,7 @@ code.  Most are defined in `rope.c'.
      NUM and strings POS and S_CALLER.  For a listing of useful
      predefined POS macros, *Note C Macros::.
 
-     *Note:* Inexact numbers are accepted only by `num2long' and
+     _Note:_ Inexact numbers are accepted only by `num2long' and
      `num2ulong' (for when `SCM' is compiled without bignums).  To
      convert inexact numbers to exact numbers, *Note inexact->exact:
      (r5rs)Numerical operations.
@@ -6622,9 +6872,9 @@ code.  Most are defined in `rope.c'.
      messages from error calls by `scm_addr'.
 
      `scm_addr' is useful for performing C operations on strings or
-     other uniform arrays (*note Uniform Array::.).
+     other uniform arrays (*note Uniform Array::).
 
-     *Note:* While you use a pointer returned from `scm_addr' you must
+     _Note:_ While you use a pointer returned from `scm_addr' you must
      keep a pointer to the associated `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.
@@ -6698,7 +6948,7 @@ conflicts.
      "root" `CONTINUATION's have additional storage (immediately
      following) to contain a copy of part of the stack.
 
-     *Note:* On systems with nonlinear stack disciplines (multiple
+     _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
      `CHEAP_CONTINUATIONS' in `scmfig.h'.
@@ -6763,7 +7013,7 @@ Evaluation
 ----------
 
 SCM uses its type representations to speed evaluation.  All of the
-`subr' types (*note Subr Cells::.) are `tc7' types.  Since the `tc7'
+`subr' types (*note Subr Cells::) are `tc7' types.  Since the `tc7'
 field is in the low order bit position of the `CAR' it can be retrieved
 and dispatched on quickly by dereferencing the SCM pointer pointing to
 it and masking the result.
@@ -6776,7 +7026,7 @@ to occupy the same bits as `tc7'.  All the `isym's occur only in the
 
 If the `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 `ILOC' or `GLOC' (*note Immediates::.).
+converted to an immediate type `ILOC' or `GLOC' (*note Immediates::).
 The codes for `ILOC' and `GLOC' lower 7 bits distinguish them from all
 the other types we have discussed.
 
@@ -6846,8 +7096,8 @@ argument checks for closures are made only when the function position
 will be checked only the first time it is evaluated because it will
 then be replaced with an `ILOC' or `GLOC'.
 
- - Macro: EVAL EXPRESSION ENV
- - Macro: SIDEVAL EXPRESSION ENV
+ - Macro: EVAL expression env
+ - Macro: SIDEVAL expression env
      `EVAL' Returns the result of evaluating EXPRESSION in ENV.
      `SIDEVAL' evaluates EXPRESSION in ENV when the value of the
      expression is not used.
@@ -6912,8 +7162,8 @@ needed.
      Given the pathname of this executable (EXEC_PATH), test for the
      existence of INITNAME in the implementation-vicinity of this
      program.  Return a newly allocated string of the path if
-     successful, 0 if not.  The SEP argument is a *null-terminated
-     string* of the character used to separate directory components.
+     successful, 0 if not.  The SEP argument is a _null-terminated
+     string_ of the character used to separate directory components.
 
    * One convention is to install the support files for an executable
      program in the same directory as the program.  This possibility is
@@ -6953,13 +7203,13 @@ File: scm.info,  Node: Executable Pathname,  Next: Script Support,  Prev: File-S
 Executable Pathname
 -------------------
 
-For purposes of finding `Init5d2.scm', dumping an executable, and             |
+For purposes of finding `Init5d6.scm', dumping an executable, and             |
 dynamic linking, a SCM session needs the pathname of its executable
 image.
 
 When a program is executed by MS-DOS, the full pathname of that
 executable is available in `argv[0]'.  This value can be passed
-directly to `find_impl_file' (*note File-System Habitat::.).
+directly to `find_impl_file' (*note 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.
@@ -7034,7 +7284,7 @@ Improvements To Make
      names.  Provide a file full of #define's to provide backward
      compatability.
 
-   * `lgcd()' *needs* to generate at most one bignum, but currently
+   * `lgcd()' _needs_ to generate at most one bignum, but currently
      generates more.
 
    * `divide()' could use shifts instead of multiply and divide when
@@ -7066,6 +7316,7 @@ Improvements To Make
           gets set which tells the interpreter to instead always look
           up the values of the associated symbols.
 
+
 * Menu:
 
 * Finishing Dynamic Linking::
@@ -7108,7 +7359,7 @@ with a VMS system needs to finish and debug it.
      PSECT_ATTR=the_heap,NOSHR,LCL
      PSECT_ATTR=the_environment,NOSHR,LCL
 
-     *Notice:* The "psect" (Program Section) attributes.
+     _Notice:_ The "psect" (Program Section) attributes.
     `LCL'
           means to keep the name local to the shared library.  You
           almost always want to do that for a good clean library.
@@ -7173,7 +7424,7 @@ with a VMS system needs to finish and debug it.
      off <C-c> or other interrupt handling while you are inside most
      `lib$' calls.
 
-     As far as the generation of all the `UNIVERSAL=...'  declarations.
+     As far as the generation of all the `UNIVERSAL=...' declarations.
      Well, you could do well to have that automatically generated from
      the public `LISPRTL.H' file, of course.
 
@@ -7272,7 +7523,7 @@ Windows NT:
       nointerrupt(iflag);
       return(retval);}
 
-   * *Note:* in VMS the linker and dynamic loader is case sensitive, but
+   * _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.
@@ -7280,7 +7531,7 @@ Windows NT:
      and device names, which are case canonicalizing like in the
      Symbolics filesystem.
 
-   * *Also:* All this WINDOWS NT stuff will work in MS-DOS MS-Windows
+   * _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.
 
@@ -7299,7 +7550,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * #+:                                    Syntax Extensions.
 * #-:                                    Syntax Extensions.
 * #.:                                    Syntax Extensions.
-* #;text-till-end-of-line:               Syntax Extensions.                   |
+* #;text-till-end-of-line:               Syntax Extensions.
 * #\token:                               Syntax Extensions.
 * #|:                                    Syntax Extensions.
 * $abs:                                  Numeric.
@@ -7349,6 +7600,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * -e:                                    SCM Options.
 * -f:                                    SCM Options.
 * -F:                                    Build Options.
+* -h <1>:                                SCM Options.
 * -h:                                    Build Options.
 * -i <1>:                                SCM Options.
 * -i:                                    Build Options.
@@ -7370,19 +7622,18 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * -v:                                    SCM Options.
 * -w:                                    Build Options.
 * @apply:                                Low Level Syntactic Hooks.
-* @call-with-current-continuation:       Low Level Syntactic Hooks.
-* @copy-tree:                            Miscellaneous Procedures.
-* @let-syntax:                           Syntactic Hooks for Hygienic Macros.
-* @letrec-syntax:                        Syntactic Hooks for Hygienic Macros.
+* @copy-tree:                            Miscellaneous Procedures.            |
 * @macroexpand1:                         Syntactic Hooks for Hygienic Macros.
+* _exclusive:                            Files and Ports.                     |
 * _ionbf:                                Files and Ports.
-* _tracked:                              Files and Ports.                     |
+* _tracked:                              Files and Ports.
 * abort:                                 Internal State.
 * access:                                I/O-Extensions.
-* acct:                                  Posix Extensions.
+* acct:                                  Unix Extensions.                     |
 * acons:                                 Miscellaneous Procedures.
 * acosh:                                 Numeric.
 * add-alias:                             Configure Module Catalog.
+* add-finalizer:                         Interrupts.                          |
 * add-link:                              Configure Module Catalog.
 * add-source:                            Configure Module Catalog.
 * alarm:                                 Interrupts.
@@ -7417,9 +7668,12 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * bit-invert!:                           Bit Vectors.
 * bit-position:                          Bit Vectors.
 * bit-set*!:                             Bit Vectors.
+* boot-tail <1>:                         Dump.                                |
+* boot-tail:                             SCM Session.                         |
 * box:                                   Curses Miscellany.
-* CAR:                                   Cells.
-* casev:                                 Syntax Extensions.
+* broken-pipe:                           Posix Extensions.                    |
+* call-with-outputs:                     Files and Ports.
+* CAR:                                   Cells.                               |
 * cbreak:                                Terminal Mode Setting.
 * CCLO_LENGTH:                           Header Cells.
 * CDR:                                   Cells.
@@ -7432,8 +7686,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * CHEAP_CONTINUATIONS:                   Continuations.
 * chmod:                                 I/O-Extensions.
 * chown:                                 Posix Extensions.
-* clearok:                               Output Options Setting.
-* close-io-port:                         Files and Ports.
+* clearok:                               Output Options Setting.              |
 * close-port <1>:                        Window Manipulation.
 * close-port <2>:                        Posix Extensions.
 * close-port:                            Files and Ports.
@@ -7442,7 +7695,6 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * CLOSUREP:                              Cells.
 * CODE:                                  Cells.
 * comment:                               Syntax Extensions.                   |
-* compile-file:                          Compiling And Linking.
 * CONSP:                                 Cells.
 * copy-tree:                             Miscellaneous Procedures.
 * cosh:                                  Numeric.
@@ -7455,6 +7707,8 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * defconst:                              Syntax Extensions.
 * DEFER_INTS:                            Signals.
 * defined?:                              Syntax Extensions.
+* defmacro:                              Syntax Extensions.
+* defsyntax:                             Low Level Syntactic Hooks.           |
 * defvar:                                Syntax Extensions.
 * dimensions->uniform-array:             Uniform Array.
 * directory-for-each:                    I/O-Extensions.
@@ -7471,8 +7725,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * enclose-array:                         Conventional Arrays.
 * end-of-program:                        Interrupts.
 * endwin:                                Curses.
-* ENV:                                   Cells.
-* environment->tree:                     Low Level Syntactic Hooks.
+* ENV:                                   Cells.                               |
 * errno:                                 Errors.
 * error:                                 Errors.
 * eval:                                  Evaluation.
@@ -7496,11 +7749,13 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * fork:                                  Posix Extensions.
 * FPORTP:                                Ptob Cells.
 * free_continuation:                     Continuations.
-* freshline:                             Files and Ports.                     |
+* freshline:                             Files and Ports.
 * gc:                                    Internal State.
+* gc-hook:                               Interrupts.                          |
 * gc_mark:                               Marking Cells.
 * GCCDR:                                 Marking Cells.
 * GCTYP16:                               Marking Cells.
+* gentemp:                               Syntax Extensions.
 * get-internal-real-time:                Time.
 * get-internal-run-time:                 Time.
 * getcwd:                                I/O-Extensions.
@@ -7510,6 +7765,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * getgr:                                 Posix Extensions.
 * getgroups:                             Posix Extensions.
 * gethost:                               Host Data.
+* getlogin:                              Posix Extensions.                    |
 * getnet:                                Host Data.
 * getpeername:                           Internet Addresses and Socket Names.
 * getpid:                                I/O-Extensions.
@@ -7541,6 +7797,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * initscr:                               Curses.
 * INPORTP:                               Ptob Cells.
 * int_signal:                            Signals.
+* integer->line-number:                  Line Numbers.                        |
 * INUM:                                  Immediates.
 * INUMP:                                 Immediates.
 * isatty?:                               Files and Ports.
@@ -7552,10 +7809,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * LENGTH:                                Header Cells.
 * line-editing:                          Line Editing.
 * line-number:                           Miscellaneous Procedures.
-* link:                                  Posix Extensions.
-* link-named-scm:                        Compiling And Linking.
-* list->uniform-array:                   Uniform Array.
-* list->uniform-vector:                  Uniform Array.
+* line-number->integer:                  Line Numbers.                        |
+* line-number?:                          Line Numbers.                        |
+* link:                                  Posix Extensions.                    |
+* list->uniform-array:                   Uniform Array.                       |
 * list-file:                             Miscellaneous Procedures.
 * load:                                  Dynamic Linking.
 * load-string:                           Miscellaneous Procedures.
@@ -7563,19 +7820,20 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * logaset!:                              Uniform Array.
 * long:                                  Type Conversions.
 * long2num:                              Type Conversions.
-* lstat:                                 Posix Extensions.
+* lstat:                                 Unix Extensions.                     |
+* macroexpand:                           Syntax Extensions.
+* macroexpand-1:                         Syntax Extensions.
 * main:                                  Embedding SCM.
 * makargvfrmstrs:                        Type Conversions.
 * makcclo:                               Header Cells.
 * make-arbiter:                          Process Synchronization.
 * make-array:                            Conventional Arrays.
 * make-edited-line-port:                 Line Editing.
+* make-exchanger:                        Process Synchronization.             |
 * make-shared-array:                     Conventional Arrays.
 * make-soft-port:                        Soft Ports.
 * make-stream-socket:                    Socket.
-* make-stream-socketpair:                Socket.
-* make-uniform-array:                    Uniform Array.
-* make-uniform-vector:                   Uniform Array.
+* make-stream-socketpair:                Socket.                              |
 * make_continuation:                     Continuations.
 * make_gsubr:                            Defining Subrs.
 * make_root_continuation:                Continuations.
@@ -7590,7 +7848,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * mark_locations:                        Marking Cells.
 * milli-alarm:                           Interrupts.
 * mkdir:                                 I/O-Extensions.
-* mknod:                                 Posix Extensions.
+* mknod:                                 Unix Extensions.                     |
 * must_free:                             Allocating memory.
 * must_free_argv:                        Type Conversions.
 * must_malloc:                           Allocating memory.
@@ -7601,7 +7859,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * NCONSP:                                Cells.
 * NEWCELL:                               Cells.
 * newwin:                                Window Manipulation.
-* nice:                                  Posix Extensions.
+* nice:                                  Unix Extensions.                     |
 * NIMP:                                  Immediates.
 * NINUMP:                                Immediates.
 * nl:                                    Terminal Mode Setting.
@@ -7614,10 +7872,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * num2long:                              Type Conversions.
 * NVECTORP:                              Header Cells.
 * open-file:                             Files and Ports.
-* open-input-pipe:                       Posix Extensions.
-* open-io-file:                          Files and Ports.
+* open-input-pipe:                       Posix Extensions.                    |
 * open-output-pipe:                      Posix Extensions.
 * open-pipe:                             Posix Extensions.
+* open-ports:                            Files and Ports.                     |
 * opendir:                               I/O-Extensions.
 * OPENP:                                 Ptob Cells.
 * OPFPORTP:                              Ptob Cells.
@@ -7631,14 +7889,19 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * overlay:                               Window Manipulation.
 * overwrite:                             Window Manipulation.
 * perror:                                Errors.
+* pi*:                                   Numeric.
+* pi/:                                   Numeric.
 * pipe:                                  Posix Extensions.
-* port-column:                           Miscellaneous Procedures.            |
-* port-filename:                         Miscellaneous Procedures.            |
-* port-line:                             Miscellaneous Procedures.            |
+* port-closed?:                          Files and Ports.                     |
+* port-column:                           Miscellaneous Procedures.
+* port-filename:                         Miscellaneous Procedures.
+* port-line:                             Miscellaneous Procedures.
+* port-type:                             Files and Ports.                     |
 * PORTP:                                 Ptob Cells.
 * print <1>:                             Miscellaneous Procedures.
 * print:                                 Debugging Scheme Code.
 * print-args:                            Debugging Scheme Code.
+* procedure->identifier-macro:           Low Level Syntactic Hooks.
 * procedure->macro:                      Low Level Syntactic Hooks.
 * procedure->memoizing-macro:            Low Level Syntactic Hooks.
 * procedure->syntax:                     Low Level Syntactic Hooks.
@@ -7647,14 +7910,17 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * profile-alarm-interrupt:               Interrupts.
 * program-arguments:                     SCM Session.
 * putenv:                                I/O-Extensions.
+* qase:                                  Syntax Extensions.                   |
 * quit:                                  SCM Session.
 * raw:                                   Terminal Mode Setting.
 * read-char <1>:                         Input.
 * read-char:                             Files and Ports.
+* read-numbered:                         Line Numbers.                        |
 * read:sharp:                            Low Level Syntactic Hooks.
 * read:sharp-char:                       Low Level Syntactic Hooks.
 * readdir:                               I/O-Extensions.
-* readlink:                              Posix Extensions.
+* readlink:                              Unix Extensions.                     |
+* record-printer-set!:                   Records.                             |
 * redirect-port!:                        I/O-Extensions.
 * refresh:                               Window Manipulation.
 * regcomp:                               Regular Expression Pattern Matching.
@@ -7728,9 +7994,10 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * STRINGP:                               Header Cells.
 * subwin:                                Window Manipulation.
 * SYMBOLP:                               Header Cells.
-* symlink:                               Posix Extensions.
-* sync:                                  Posix Extensions.
+* symlink:                               Unix Extensions.                     |
+* sync:                                  Unix Extensions.                     |
 * syntax-quote:                          Syntactic Hooks for Hygienic Macros.
+* syntax-rules:                          Syntax Extensions.
 * tanh:                                  Numeric.
 * terms:                                 Miscellaneous Procedures.
 * the-macro:                             Syntactic Hooks for Hygienic Macros.
@@ -7742,6 +8009,8 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * trace:                                 Debugging Scheme Code.
 * transpose-array:                       Conventional Arrays.
 * try-arbiter:                           Process Synchronization.
+* try-create-file:                       I/O-Extensions.                      |
+* try-load <1>:                          Line Numbers.                        |
 * try-load:                              Miscellaneous Procedures.
 * try-open-file:                         Files and Ports.
 * ttyname:                               Posix Extensions.
@@ -7755,12 +8024,7 @@ This is an alphabetical list of all the procedures and macros in SCM.
 * unctrl:                                Curses Miscellany.
 * uniform-array-read!:                   Uniform Array.
 * uniform-array-write:                   Uniform Array.
-* uniform-vector-fill!:                  Uniform Array.
-* uniform-vector-length:                 Uniform Array.
-* uniform-vector-read!:                  Uniform Array.
-* uniform-vector-ref:                    Uniform Array.
-* uniform-vector-set!:                   Uniform Array.
-* uniform-vector-write:                  Uniform Array.
+* uniform-vector-fill!:                  Uniform Array.                       |
 * untrace:                               Debugging Scheme Code.
 * user-interrupt:                        Interrupts.
 * usr:lib:                               Dynamic Linking.
@@ -7802,13 +8066,16 @@ This is an alphabetical list of all the global variables in SCM.
 
 * Menu:
 
+* $pi:                                   Numeric.
 * *argv*:                                SCM Variables.
 * *execpath:                             Embedding SCM.
 * *interactive* <1>:                     Internal State.
 * *interactive*:                         SCM Variables.
 * *load-pathname*:                       Miscellaneous Procedures.
-* *R4RS-macro*:                          SCM Variables.
+* *load-reader*:                         Line Numbers.                        |
 * *scm-version*:                         Internal State.
+* *slib-load-reader*:                    Line Numbers.                        |
+* *syntax-rules*:                        SCM Variables.                       |
 * af_inet:                               Host Data.
 * af_unix:                               Host Data.
 * BOOL_F:                                Immediates.
@@ -7828,6 +8095,7 @@ This is an alphabetical list of all the global variables in SCM.
 * open_both:                             Files and Ports.
 * open_read:                             Files and Ports.
 * open_write:                            Files and Ports.
+* pi:                                    Numeric.
 * SCHEME_LIBRARY_PATH:                   SCM Variables.
 * SCM_INIT_PATH:                         SCM Variables.
 * symhash:                               Evaluation.
@@ -7911,6 +8179,7 @@ This is an alphabetical list of data types and feature names in SCM.
 * tc7_subr_2:                            Subr Cells.
 * tc7_subr_2o:                           Subr Cells.
 * tc7_subr_3:                            Subr Cells.
+* tc7_svect:                             Header Cells.                        |
 * tc7_uvect:                             Header Cells.
 * tc7_vector:                            Header Cells.
 * tc_dblc:                               Smob Cells.
@@ -7926,174 +8195,189 @@ Concept Index
 
 * Menu:
 
-* !#:                                    MS-DOS Compatible Scripts.           |
-* !#.exe:                                MS-DOS Compatible Scripts.           |
-* #!:                                    MS-DOS Compatible Scripts.           |
-* #!.bat:                                MS-DOS Compatible Scripts.           |
-* array <1>:                             Conventional Arrays.                 |
-* array:                                 Build Options.                       |
-* array-for-each:                        Build Options.                       |
-* arrays:                                Build Options.                       |
-* bignums:                               Build Options.                       |
+* !#:                                    MS-DOS Compatible Scripts.
+* !#.exe:                                MS-DOS Compatible Scripts.
+* #!:                                    MS-DOS Compatible Scripts.
+* #!.bat:                                MS-DOS Compatible Scripts.
+* array <1>:                             Conventional Arrays.
+* array:                                 Build Options.
+* array-for-each:                        Build Options.
+* arrays:                                Build Options.
+* bignums:                               Build Options.
 * callbacks:                             Callbacks.
-* careful-interrupt-masking:             Build Options.                       |
-* cautious:                              Build Options.                       |
-* cheap-continuations:                   Build Options.                       |
-* compiled-closure:                      Build Options.                       |
+* careful-interrupt-masking:             Build Options.
+* cautious:                              Build Options.
+* cheap-continuations:                   Build Options.
+* compiled-closure:                      Build Options.
 * continuations:                         Continuations.
-* curses:                                Build Options.                       |
-* debug:                                 Build Options.                       |
+* curses:                                Build Options.
+* debug:                                 Build Options.
 * documentation string:                  Syntax Extensions.
-* dump:                                  Build Options.                       |
-* dynamic-linking:                       Build Options.                       |
-* edit-line:                             Build Options.                       |
+* dump:                                  Build Options.
+* dynamic-linking:                       Build Options.
+* ecache:                                Memory Management for Environments.  |
+* edit-line:                             Build Options.
 * Embedding SCM:                         Embedding SCM.
-* engineering-notation:                  Build Options.                       |
-* Exrename:                              Bibliography.                        |
+* engineering-notation:                  Build Options.
+* environments:                          Memory Management for Environments.  |
+* exchanger:                             Process Synchronization.             |
+* Exrename:                              Bibliography.
 * Extending Scm:                         Compiling and Linking Custom Files.
 * foo.c:                                 Compiling and Linking Custom Files.
-* generalized-c-arguments:               Build Options.                       |
-* GUILE:                                 Bibliography.                        |
-* i/o-extensions:                        Build Options.                       |
-* IEEE:                                  Bibliography.                        |
-* inexact:                               Build Options.                       |
-* JACAL:                                 Bibliography.                        |
-* lit:                                   Build Options.                       |
-* macro:                                 Build Options.                       |
-* mysql:                                 Build Options.                       |
-* no-heap-shrink:                        Build Options.                       |
-* none:                                  Build Options.                       |
-* posix:                                 Build Options.                       |
-* R4RS:                                  Bibliography.                        |
-* R5RS:                                  Bibliography.                        |
-* reckless:                              Build Options.                       |
-* record:                                Build Options.                       |
-* regex:                                 Build Options.                       |
-* rev2-procedures:                       Build Options.                       |
-* SICP:                                  Build Options.                       |
-* sicp:                                  Build Options.                       |
-* SICP:                                  Bibliography.                        |
+* generalized-c-arguments:               Build Options.
+* graphics:                              Packages.
+* hobbit:                                Packages.                            |
+* i/o-extensions:                        Build Options.
+* IEEE:                                  Bibliography.
+* inexact:                               Build Options.
+* JACAL:                                 Bibliography.
+* lit:                                   Build Options.
+* macro:                                 Build Options.
+* memory management:                     Memory Management for Environments.  |
+* mysql:                                 Build Options.
+* no-heap-shrink:                        Build Options.
+* NO_ENV_CACHE:                          Memory Management for Environments.  |
+* none:                                  Build Options.
+* posix:                                 Build Options.
+* R4RS:                                  Bibliography.
+* R5RS:                                  Bibliography.
+* reckless:                              Build Options.
+* record:                                Build Options.
+* regex:                                 Build Options.
+* rev2-procedures:                       Build Options.
+* SchemePrimer:                          Bibliography.
+* SICP:                                  Build Options.
+* sicp:                                  Build Options.
+* SICP:                                  Bibliography.
 * signals:                               Signals.
-* Simply:                                Bibliography.                        |
-* single-precision-only:                 Build Options.                       |
-* SLIB:                                  Bibliography.                        |
-* socket:                                Build Options.                       |
-* stack-limit:                           Build Options.                       |
-* tick-interrupts:                       Build Options.                       |
-* turtlegr:                              Build Options.                       |
-* unix:                                  Build Options.                       |
-* windows:                               Build Options.                       |
-* x:                                     Build Options.                       |
-* xlib:                                  Build Options.                       |
+* Simply:                                Bibliography.
+* single-precision-only:                 Build Options.
+* SLIB:                                  Bibliography.
+* socket:                                Build Options.
+* stack-limit:                           Build Options.
+* tick-interrupts:                       Build Options.
+* turtlegr:                              Build Options.
+* unix:                                  Build Options.
+* windows:                               Build Options.
+* X:                                     Packages.
+* x <1>:                                 Packages.
+* x:                                     Build Options.
+* xlib:                                  Packages.
+* Xlib:                                  Packages.
+* xlib:                                  Build Options.
+* xlibscm:                               Packages.
+* Xlibscm:                               Packages.
 
 
 
 Tag Table:
-Node: Top229
-Node: Overview1521
-Node: Copying1832
-Node: SCM Features4894
-Node: SCM Authors6905
-Node: Bibliography7805
-Node: Installing SCM9676
-Node: Making SCM10191
-Node: SLIB11531
-Node: Building SCM13549
-Node: Invoking Build14091
-Node: Build Options16112
-Node: Compiling and Linking Custom Files33008
-Node: Installing Dynamic Linking34986
-Node: Configure Module Catalog36770
-Node: Saving Images38767
-Node: Automatic C Preprocessor Definitions39443
-Node: Problems Compiling42659
-Node: Problems Linking44785
-Node: Problems Running45087
-Node: Testing47643
-Node: Reporting Problems50980
-Node: Operational Features51823
-Node: Invoking SCM52187
-Node: SCM Options53748
-Node: Invocation Examples57904
-Node: SCM Variables58856
-Node: SCM Session60306
-Node: Editing Scheme Code61429
-Node: Debugging Scheme Code63563
-Node: Errors67202
-Node: Memoized Expressions71502
-Node: Internal State73866
-Node: Scripting76918
-Node: Unix Scheme Scripts77212
-Node: MS-DOS Compatible Scripts80423
-Node: Unix Shell Scripts82236
-Node: The Language84425
-Node: Standards Compliance85000
-Node: Miscellaneous Procedures87415
-Node: Time90765
-Node: Interrupts91759
-Node: Process Synchronization95369
-Node: Files and Ports95909
-Node: Soft Ports101092
-Node: Syntax Extensions102768
-Node: Low Level Syntactic Hooks109753
-Node: Syntactic Hooks for Hygienic Macros113664
-Node: Packages120817
-Node: Compiling And Linking121493
-Node: Dynamic Linking123530
-Node: Dump128154
-Node: Numeric132264
-Node: Arrays133820
-Node: Conventional Arrays134037
-Node: Array Mapping140675
-Node: Uniform Array142909
-Node: Bit Vectors148821
-Node: I/O-Extensions150086
-Node: Posix Extensions158379
-Node: Regular Expression Pattern Matching169109
-Node: Line Editing173064
-Node: Curses174410
-Node: Output Options Setting175333
-Node: Terminal Mode Setting177981
-Node: Window Manipulation181059
-Node: Output184519
-Node: Input188145
-Node: Curses Miscellany189172
-Node: Sockets190596
-Node: Host Data190920
-Node: Internet Addresses and Socket Names194068
-Node: Socket195602
-Node: The Implementation202838
-Node: Data Types203097
-Node: Immediates203918
-Node: Cells208254
-Node: Header Cells210346
-Node: Subr Cells213327
-Node: Ptob Cells215545
-Node: Smob Cells217091
-Node: Data Type Representations220290
-Node: Operations224909
-Node: Garbage Collection225495
-Node: Marking Cells226116
-Node: Sweeping the Heap228218
-Node: Memory Management for Environments229163
-Node: Signals233720
-Node: C Macros235264
-Node: Changing Scm236387
-Node: Defining Subrs240660
-Node: Defining Smobs242537
-Node: Defining Ptobs245521
-Node: Allocating memory246698
-Node: Embedding SCM248860
-Node: Callbacks256514
-Node: Type Conversions258317
-Node: Continuations261874
-Node: Evaluation266088
-Node: Program Self-Knowledge271253
-Node: File-System Habitat271499
-Node: Executable Pathname275099
-Node: Script Support276718
-Node: Improvements To Make278036
-Node: Finishing Dynamic Linking280067
-Node: Index287814
+Node: Top203
+Node: Overview1481
+Node: SCM Features1792
+Node: SCM Authors3804
+Node: Copying4742
+Node: Bibliography7831
+Node: Installing SCM9699
+Node: Making SCM10214
+Node: SLIB11131
+Node: Building SCM13149
+Node: Invoking Build13723
+Node: Build Options16516
+Node: Compiling and Linking Custom Files29598
+Node: Installing Dynamic Linking31577
+Node: Configure Module Catalog33361
+Node: Saving Images35358
+Node: Automatic C Preprocessor Definitions36033
+Node: Problems Compiling39541
+Node: Problems Linking41194
+Node: Problems Running41459
+Node: Testing43567
+Node: Reporting Problems46654
+Node: Operational Features47577
+Node: Invoking SCM47941
+Node: SCM Options49585
+Node: Invocation Examples54026
+Node: SCM Variables54978
+Node: SCM Session56487
+Node: Editing Scheme Code58010
+Node: Debugging Scheme Code60153
+Node: Errors63776
+Node: Memoized Expressions68075
+Node: Internal State70439
+Node: Scripting73727
+Node: Unix Scheme Scripts74021
+Node: MS-DOS Compatible Scripts77233
+Node: Unix Shell Scripts79045
+Node: The Language81235
+Node: Standards Compliance81890
+Node: Miscellaneous Procedures84304
+Node: Time87460
+Node: Interrupts88454
+Node: Process Synchronization94464
+Node: Files and Ports97244
+Node: Line Numbers104204
+Node: Soft Ports108304
+Node: Syntax Extensions110296
+Node: Low Level Syntactic Hooks119654
+Node: Syntactic Hooks for Hygienic Macros126507
+Node: Packages133588
+Node: Dynamic Linking134544
+Node: Dump139232
+Node: Numeric143350
+Node: Arrays145077
+Node: Conventional Arrays145366
+Node: Array Mapping152015
+Node: Uniform Array154278
+Node: Bit Vectors160302
+Node: Records161567
+Node: I/O-Extensions163253
+Node: Posix Extensions172179
+Node: Unix Extensions182353
+Node: Regular Expression Pattern Matching184358
+Node: Line Editing188387
+Node: Curses189733
+Node: Output Options Setting190656
+Node: Terminal Mode Setting193305
+Node: Window Manipulation196383
+Node: Output199843
+Node: Input203469
+Node: Curses Miscellany204496
+Node: Sockets205920
+Node: Host Data206244
+Node: Internet Addresses and Socket Names209392
+Node: Socket210926
+Node: The Implementation218163
+Node: Data Types218422
+Node: Immediates219243
+Node: Cells223579
+Node: Header Cells225671
+Node: Subr Cells228892
+Node: Ptob Cells231110
+Node: Smob Cells232649
+Node: Data Type Representations235845
+Node: Operations240503
+Node: Garbage Collection241089
+Node: Marking Cells241710
+Node: Sweeping the Heap243812
+Node: Memory Management for Environments244757
+Node: Signals249314
+Node: C Macros250858
+Node: Changing Scm251981
+Node: Defining Subrs256253
+Node: Defining Smobs258130
+Node: Defining Ptobs261265
+Node: Allocating memory262442
+Node: Embedding SCM264833
+Node: Callbacks272486
+Node: Type Conversions274289
+Node: Continuations277845
+Node: Evaluation282059
+Node: Program Self-Knowledge287222
+Node: File-System Habitat287468
+Node: Executable Pathname291068
+Node: Script Support292686
+Node: Improvements To Make294004
+Node: Finishing Dynamic Linking296036
+Node: Index303782
 
 End Tag Table
diff --git a/scm.spec b/scm.spec
new file mode 100644
index 0000000..4be109c
--- /dev/null
+++ b/scm.spec
@@ -0,0 +1,168 @@
+%define name scm
+%define version 5d6
+%define release 1
+%define implpath %{prefix}/lib/scm
+# rpm seems to require all on one line, bleah.
+%define features cautious bignums arrays inexact dump dynamic-linking macro engineering-notation
+
+Name:         %{name}
+Release:      %{release}
+Version:      %{version}
+Packager:     Radey Shouman <shouman@ne.mediaone.net>
+
+Copyright:    GPL
+Vendor:       Aubrey Jaffer <agj @ alum.mit.edu>
+Group:        Development/Languages
+Provides:     scm
+Requires:     slib
+
+Summary: SCM Scheme implementation.
+Source:       ftp://swissnet.ai.mit.edu/pub/scm/scm%{version}.zip
+URL:          http://swissnet.ai.mit.edu/~jaffer/SCM.html
+BuildRoot:    %{_tmppath}/%{name}%{version}
+Prefix:       /usr
+
+%description
+Scm conforms to Revised^5 Report on the Algorithmic Language Scheme and
+the IEEE P1178 specification.  Scm provides a machine independent
+platform for JACAL, a symbolic algebra system.
+
+This distribution requires libdl.so from the glibc-devel package and the
+slib Scheme library package.  If your machine lacks XFree86 or readline,
+install with --nodeps.
+
+%define __os_install_post /usr/lib/rpm/brp-compress
+
+%prep
+rm -rf /var/tmp/%{name}%{version}
+%setup -n scm -c -T
+cd ..
+unzip $RPM_SOURCE_DIR/scm%{version}.zip
+
+%build
+# SLIB is required to build SCM.
+if [ -n "$SCHEME_LIBRARY_PATH" ]; then
+  echo using SLIB $SCHEME_LIBRARY_PATH
+elif [ -d /usr/share/slib ]; then
+  export SCHEME_LIBRARY_PATH=/usr/share/slib/
+elif [ -d /usr/lib/slib ]; then
+  export SCHEME_LIBRARY_PATH=/usr/lib/slib/
+fi
+make scmlit
+make clean
+export PATH=.:$PATH   # to get scmlit in the path.
+
+# Build the executable.
+./build -h system -o udscm5 -l debug -s %{implpath} -F %{features}
+echo "(quit)" | ./udscm5 -no-init-file -r5 -o scm
+make check
+
+# Build dlls
+make x.so
+./build -h system -F curses -t dll
+./build -h system -t dll -c sc2.c rgx.c record.c gsubr.c ioext.c posix.c \
+	    unix.c socket.c ramap.c
+./build -h system -F edit-line -t dll
+./build -h system -F x -t dll
+
+# Build libscm.a static library
+./build -h system -F cautious bignums arrays inexact dynamic-linking -t lib
+
+%install
+mkdir -p ${RPM_BUILD_ROOT}%{prefix}/bin
+mkdir -p ${RPM_BUILD_ROOT}%{prefix}/lib/scm
+mkdir -p ${RPM_BUILD_ROOT}%{prefix}/man/man1
+make prefix=${RPM_BUILD_ROOT}%{prefix}/  install
+make prefix=${RPM_BUILD_ROOT}%{prefix}/  installlib
+rm -f ${RPM_BUILD_ROOT}%{prefix}/bin/scm
+cp udscm5 ${RPM_BUILD_ROOT}%{prefix}/bin/
+
+# Assume SLIB is in /usr/share/slib, as installed by the slib rpm.
+cat > ${RPM_BUILD_ROOT}%{prefix}/lib/scm/require.scm <<EOF
+(set! library-vicinity (lambda () "%{prefix}/share/slib/"))
+EOF
+
+mkdir -p ${RPM_BUILD_ROOT}%{prefix}/info/
+gzip *.info
+cp *.info.gz ${RPM_BUILD_ROOT}%{prefix}/info/
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+
+%post
+/sbin/install-info /usr/info/scm.info.gz /usr/info/dir
+/sbin/install-info /usr/info/hobbit.info.gz /usr/info/dir
+/sbin/install-info /usr/info/Xlibscm.info.gz /usr/info/dir
+echo "(quit)" | %{prefix}/bin/udscm5 -no-init-file -r5 -o %{prefix}/bin/scm
+ln -s %{prefix}/bin/scm /usr/local/bin/scm
+ln -s %{prefix}/lib/scm /usr/local/lib/
+/usr/bin/scm -c "(require 'new-catalog)"
+
+%verifyscript
+cp -f %{prefix}/lib/scm/r4rstest.scm /tmp/
+(cd /tmp
+    %{prefix}/bin/scm -fr4rstest.scm -e'(test-sc4)(test-cont)(test-delay)(gc)')
+
+%preun
+rm -f %{prefix}/lib/scm/slibcat %{prefix}/lib/scm/implcat
+if [ -L /usr/local/bin/scm ] && \
+    ls -l /usr/local/bin/scm | grep -q "> %{prefix}/bin/scm"; then
+  rm -f /usr/local/bin/scm
+fi
+if [ -L /usr/local/lib/scm ] && \
+    ls -l /usr/local/lib/scm | grep -q "> %{prefix}/lib/scm"; then
+  rm -f /usr/local/lib/scm
+fi
+rm -f %{prefix}/bin/scm
+
+%files
+%defattr(-, root, root)
+%{prefix}/bin/scmlit
+%{prefix}/bin/udscm5
+%dir %{prefix}/lib/scm
+# No wildcards here because we need to segregate files by package.
+%{prefix}/lib/scm/crs.so
+%{prefix}/lib/scm/gsubr.so
+%{prefix}/lib/scm/posix.so
+%{prefix}/lib/scm/record.so
+%{prefix}/lib/scm/sc2.so
+%{prefix}/lib/scm/unix.so
+%{prefix}/lib/scm/ioext.so
+%{prefix}/lib/scm/ramap.so
+%{prefix}/lib/scm/socket.so
+%{prefix}/lib/scm/rgx.so
+%{prefix}/lib/scm/Init%{version}.scm
+%{prefix}/lib/scm/require.scm
+%{prefix}/lib/scm/Macexp.scm
+%{prefix}/lib/scm/Macro.scm
+%{prefix}/lib/scm/Tscript.scm
+%{prefix}/lib/scm/Transcen.scm
+%{prefix}/lib/scm/mkimpcat.scm
+%{prefix}/lib/scm/Link.scm
+%{prefix}/lib/scm/compile.scm
+%{prefix}/lib/scm/hobbit.scm
+%{prefix}/lib/scm/scmhob.scm
+%{prefix}/lib/scm/scmhob.h
+%{prefix}/lib/scm/build.scm
+%{prefix}/lib/scm/build
+%{prefix}/lib/scm/Iedline.scm
+%{prefix}/lib/scm/edline.so
+%{prefix}/lib/scm/x.so
+%{prefix}/lib/scm/xevent.scm
+%{prefix}/lib/scm/xatoms.scm
+%{prefix}/lib/scm/x11.scm
+%{prefix}/lib/scm/keysymdef.scm
+%{prefix}/lib/scm/r4rstest.scm
+/usr/info/Xlibscm.info.gz
+/usr/info/hobbit.info.gz
+/usr/info/scm.info.gz
+/usr/man/man1/scm.1.gz
+
+%{prefix}/lib/libscm.a
+%{prefix}/include/scm.h
+%{prefix}/include/scmfig.h
+%{prefix}/include/scmflags.h
+
+%doc ANNOUNCE COPYING QUICKREF README ChangeLog
+
+%changelog
diff --git a/scm.texi b/scm.texi
index 16a33d0..f0cd485 100644
--- a/scm.texi
+++ b/scm.texi
@@ -114,86 +114,13 @@ home page:
 @end iftex
 
 @menu
-* Copying::                     
 * SCM Features::                
 * SCM Authors::                 
+* Copying::                     
 * Bibliography::                
 @end menu
 
-@node Copying, SCM Features, Overview, Overview
-@section 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 59 Temple Place, Suite 330, Boston, MA 02111, 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 SCM Features, SCM Authors, Copying, Overview
+@node SCM Features, SCM Authors, Overview, Overview
 @section Features
 
 @itemize @bullet
@@ -243,14 +170,14 @@ timing information printed interactively (the @code{verbose} function).
 @code{Restart}, @code{quit}, and @code{exec}.
 @end itemize
 
-@node SCM Authors, Bibliography, SCM Features, Overview
+@node SCM Authors, Copying, SCM Features, Overview
 @section Authors
 
 @table @b
-@item Aubrey Jaffer (jaffer @@ ai.mit.edu)
+@item Aubrey Jaffer (jaffer @@ alum.mit.edu)
 Most of SCM.
 @item Radey Shouman
-Arrays. @code{gsubr}s, compiled closures, records, Ecache, syntax-rules
+Arrays, @code{gsubr}s, compiled closures, records, Ecache, syntax-rules
 macros, and @dfn{safeport}s.
 @item Jerry D. Hedden
 Real and Complex functions.  Fast mixed type arithmetics.
@@ -268,33 +195,94 @@ C-stack and being able to garbage collect off the C-stack
 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,  , SCM Authors, Overview
+@node Copying, Bibliography, SCM Authors, Overview
+@section Copyright
+
+@noindent
+Authors have assigned their SCM copyrights to:
+@sp 1
+
+@center Free Software Foundation, Inc.
+@center 59 Temple Place, Suite 330, Boston, MA 02111, 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.
+
+
+@heading SIOD copyright
+@sp 1
+
+@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
+
+@node Bibliography,  , Copying, Overview
 @section Bibliography
 
 @table @asis
+
 @item [IEEE]
 @cindex IEEE
 @cite{IEEE Standard 1178-1990.  IEEE Standard for the Scheme
 Programming Language.}  IEEE, New York, 1991.
 
-@item [Simply]
-@cindex 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]
-@cindex SICP
-Harold Abelson and Gerald Jay Sussman with Julie Sussman.
-@cite{Structure and Interpretation of Computer Programs.}
-MIT Press, Cambridge, 1985.
-
 @item [R4RS]
 @cindex R4RS
 William Clinger and Jonathan Rees, Editors.
@@ -345,17 +333,46 @@ Hygienic Macros Through Explicit Renaming
 @cite{Lisp Pointers} Volume IV, Number 4 (December 1991),
 pp 17-23.
 
-@item [GUILE]
-@cindex GUILE
-Tom Lord.
+@item [SICP]
+@cindex SICP
+Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+@cite{Structure and Interpretation of Computer Programs.}
+MIT Press, Cambridge, 1985.
+
+@item [Simply]
+@cindex 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 [SchemePrimer]
+@cindex SchemePrimer
+$B8$;tBg(B(Dai Inukai)
 @ifset html
-<A HREF="http://www.cygnus.com/library/ctr/guile.html">
+<A HREF="http://www.shuwasystem.co.jp/SchemePrimer/">
 @end ifset
-The Guile Architecture for Ubiquitous Computing.
+@cite{$BF~Lg(BScheme}
 @ifset html
 </A>
 @end ifset
-@cite{Usenix Symposium on Tcl/Tk}, 1995.
+1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7
+
+@c  @item [GUILE]
+@c  @cindex GUILE
+@c  Free Software Foundation
+@c  @ifset html
+@c  <A HREF="http://www.gnu.org/software/guile/guile.html">
+@c  @end ifset
+@c  Guile: Project GNU's extension language
+@c  @ifset html
+@c  </A>
+@c  @end ifset
 
 @item [SLIB]
 @cindex SLIB
@@ -367,7 +384,7 @@ SLIB, The Portable Scheme Library.
 @ifset html
 </A>
 @end ifset
-Version 2c5, Jan 1999.
+Version 2c8, June 2000.
 @ifinfo
 
 @ref{Top, , , slib, SLIB}.
@@ -383,7 +400,7 @@ JACAL Symbolic Mathematics System.
 @ifset html
 </A>
 @end ifset
-Version 1a9, Jan 1999.
+Version 1b0, Sep 1999.
 @ifinfo
 
 @ref{Top, , , jacal, JACAL}.
@@ -424,40 +441,29 @@ Documentation of the Xlib - SCM Language X Interface.
 
 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.
+@file{build}.  @file{build} 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:
+it.  If you need to compile SCM without build, 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;
+Use the @uref{http://swissnet.ai.mit.edu/~jaffer/buildscm.html, build}
+web page to create custom batch scripts for compiling SCM.
 
 @item
-Use another implementation of Scheme to run @file{build.scm} to create a
-script to build SCM;
+Use SCM on a different platform to run @file{build} 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.
+Use another implementation of Scheme to run @file{build} to create a
+script to build SCM;
 
 @item
-Use scmconfig (From: bos@@scrg.cs.tcd.ie):
-
-Build and install scripts using GNU @dfn{autoconf} are available from
-@file{scmconfig4e3.tar.gz} in the distribution directories.  See
-@file{README.unix} in @file{scmconfig4e3.tar.gz} for further
-instructions.
-
-@emph{Note:} The last release of scmconfig (4e3) was on March 20, 1996.
-I am moving it to the OLD subdirectory until someone submits an update.
+Create your own script or @file{Makefile}.
 @end itemize
 
 
@@ -474,34 +480,34 @@ low priority.  SLIB is available from the same sites as SCM:
 @ifclear html
 @itemize @bullet
 @item
-swissnet.ai.mit.edu:/pub/scm/slib2c7.tar.gz
+swissnet.ai.mit.edu:/pub/scm/slib2d4.tar.gz
 @item
-ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz
+ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
 @item
-ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2c7.tar.gz
+ftp.cs.indiana.edu:/pub/scheme-repository/imp/slib2d4.tar.gz
 @end itemize
 @end ifclear
 
 @ifset html
 @itemize @bullet
 @item
-<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip">
-http://swissnet.ai.mit.edu/ftpdir/scm/slib2c7.zip
+<A HREF="http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip">
+http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip
 </A>
 @item
-<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2c7.tar.gz">
-ftp.gnu.org:/pub/gnu/jacal/slib2c7.tar.gz
+<A HREF="ftp://ftp.gnu.org/pub/gnu/jacal/slib2d4.tar.gz">
+ftp.gnu.org:/pub/gnu/jacal/slib2d4.tar.gz
 </A>
 @item
-<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2c7.tar.gz">
-ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2c7.tar.gz
+<A HREF="ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lib/slib2d4.tar.gz">
+ftp.cs.indiana.edu:/pub/scheme-repository/code/lib/slib2d4.tar.gz
 </A>
 @end itemize
 @end ifset
 
 @noindent
-Unpack SLIB (@samp{tar xzf slib2c7.tar.gz} or @samp{unzip -ao
-slib2c7.zip}) in an appropriate directory for your system; both
+Unpack SLIB (@samp{tar xzf slib2d4.tar.gz} or @samp{unzip -ao
+slib2d4.zip}) in an appropriate directory for your system; both
 @code{tar} and @code{unzip} will create the directory @file{slib}.
 
 @noindent
@@ -541,11 +547,12 @@ absolute pathnames are recommended.
 @node Building SCM, Installing Dynamic Linking, SLIB, 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.
+The file @dfn{build} loads the file @dfn{build.scm}, which constructs a
+relational database of how to compile and link SCM executables.
+@file{build.scm} has information for the 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::              
@@ -558,7 +565,7 @@ additions to jaffer @@ ai.mit.edu.
 
 @noindent
 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}.
+the @emph{all} method if you encounter problems with @file{build}.
 
 @table @asis
 @item MS-DOS
@@ -566,12 +573,12 @@ 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
+From the SCM source directory, type @samp{./build} 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
+type @code{(load "build")}.  Alternatively, start @samp{scm} or
 @samp{scmlit} with the command line argument @samp{-ilbuild}.
 
 @end table
@@ -582,18 +589,20 @@ script with the @code{arrays}, @code{inexact}, and @code{bignums}
 options as defaults.
 
 @example
-bash$ ./build.scm
+bash$ ./build
 @print{}
-#!/bin/sh
+#! /bin/sh
+# unix (linux) script created by SLIB/batch 
+# ================ Write file with C defines
 rm -f scmflags.h
-echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h
+echo '#define IMPLINIT "Init@value{SCMVERSION}.scm"'>>scmflags.h
 echo '#define BIGNUMS'>>scmflags.h
 echo '#define FLOATS'>>scmflags.h
 echo '#define ARRAYS'>>scmflags.h
-gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \
-        eval.c sys.c subr.c unif.c rope.c
-gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \
-        repl.o scl.o eval.o sys.o subr.o unif.o rope.o -lm -lc
+# ================ Compile C source files
+gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
+# ================ Link C object files
+gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
 @end example
 
 @noindent
@@ -602,21 +611,18 @@ or @samp{--platform=} option.  This will create a script for the
 platform named in the @samp{-p} or @samp{--platform=} option.
 
 @example
-bash$ ./build.scm -p vms
+bash$ ./build -o scmlit -p darwin -F lit
 @print{}
-$DELETE scmflags.h
-$CREATE scmflags.h
-$DECK
-#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"
-#define BIGNUMS
-#define FLOATS
-#define ARRAYS
-$EOD
-$ cc continue scm findexec script time repl scl eval sys subr unif rope
-$ macro setjump
-$ link continue,scm,findexec,script,time,repl,scl,eval,sys,subr,unif,rope,setjump,sys$input/opt
-    -lc,sys$share:vaxcrtl/share
-$RENAME continue.exe scm.exe
+#! /bin/sh
+# unix (darwin) script created by SLIB/batch 
+# ================ Write file with C defines
+rm -f scmflags.h
+echo '#define IMPLINIT "Init@value{SCMVERSION}.scm"'>>scmflags.h
+# ================ Compile C source files
+cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
+# ================ Link C object files
+mv -f scmlit scmlit~
+cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o
 @end example
 
 
@@ -731,7 +737,7 @@ dos
 @item
 vms
 @item
-amigados
+amigaos (was amigados)
 @item
 system
 
@@ -789,7 +795,7 @@ compile and link your file at compile time, use the @samp{-c} and
 @example
 bash$ build -c foo.c -i init_foo
 @print{}
-#!/bin/sh
+#! /bin/sh
 rm -f scmflags.h
 echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h
 echo '#define COMPILED_INITS init_foo();'>>scmflags.h
@@ -808,7 +814,7 @@ To make a dynamically loadable object file use the @code{-t dll} option:
 @example
 bash$ build -t dll -c foo.c
 @print{}
-#!/bin/sh
+#! /bin/sh
 rm -f scmflags.h
 echo '#define IMPLINIT "/home/jaffer/scm/Init@value{SCMVERSION}.scm"'>>scmflags.h
 echo '#define BIGNUMS'>>scmflags.h
@@ -987,8 +993,9 @@ __WATCOMC__     Watcom C on MS-DOS
 __ZTC__         Zortech C
 
 _AIX            AIX operating system
+__APPLE__       Apple Darwin
 AMIGA           SAS/C 5.10 or Dice C on AMIGA
-__amigados__    Gnu CC on AMIGA
+__amigaos__     Gnu CC on AMIGA
 atarist         ATARI-ST under Gnu CC
 __FreeBSD__     FreeBSD
 GNUDOS          DJGPP (obsolete in version 1.08)
@@ -997,11 +1004,12 @@ hpux            HP-UX
 linux           Linux
 macintosh       Macintosh (THINK_C and __MWERKS__ define)
 MCH_AMIGA       Aztec_c 5.2a on AMIGA
+__MACH__        Apple Darwin
 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.
-__svr4__        SunOS
+__SVR4          SunOS
 THINK_C         developement environment for the Macintosh
 ultrix          VAX with ULTRIX operating system.
 unix            most Unix and similar systems and DJGPP (!?)
@@ -1021,6 +1029,8 @@ hp9000s800      HP RISC processor
 __i386__        DJGPP
 i386            DJGPP
 MULTIMAX        Encore computer
+ppc             PowerPC
+__ppc__         PowerPC
 pyr             Pyramid 9810 processor
 __sgi__         Silicon Graphics Inc.
 sparc           SPARC processor
@@ -1159,13 +1169,13 @@ digits of pi.
 > (load "pi")
 ;loading "pi"
 ;done loading "pi.scm"
-;Evaluation took 20 mSec (0 in gc) 767 cells work, 233 bytes other
+;Evaluation took 20 ms (0 in gc) 767 cells work, 233.B 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
+;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other
 #<unspecified>
 @end example
 
@@ -1220,7 +1230,7 @@ call-with-current-continuations.
 @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
+can send a bug report to @code{jaffer @@ alum.mit.edu}.  The bug report
 should include:
 
 @enumerate
@@ -1262,10 +1272,11 @@ vendor is recommended.
 @section Invoking SCM
 
 @example
-@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{}]}
+@exdent @b{ scm } [-a @i{kbytes}] [-muvbiq] @w{[--version]} @w{[--help]}
+@w{[[-]-no-init-file]} @w{[-p @i{int}]} @w{[-r @i{feature}]} @w{[-h @i{feature}]}
+@w{[-d @i{filename}]} @w{[-f @i{filename}]} @w{[-l @i{filename}]}
+@w{[-c @i{expression}]} @w{[-e @i{expression}]} @w{[-o @i{dumpname}]}
+@w{[-- | - | -s]} @w{[@i{filename}]} @w{[@i{arguments} @dots{}]}
 @end example
 
 @noindent
@@ -1291,7 +1302,7 @@ Unless the option @code{-no-init-file} or @code{--no-init-file} occurs
 in the command line, @file{Init@value{SCMVERSION}.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.
+@var{HOME} is undefined).  If it finds such a file it is loaded.
 
 @noindent
 @file{Init@value{SCMVERSION}.scm} then looks for command input from one
@@ -1311,12 +1322,12 @@ Extensions, #!}.
 @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)}.
+@deffn {Command Option} -a k
+specifies that @code{scm} should allocate an initial heapsize of @var{k}
+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
@@ -1324,72 +1335,101 @@ distribution sets at @code{25000*sizeof(cell)}.
 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)"}.
+@deffn {Command Option} ---help
+prints usage information and URI; then exit.
+@end deffn
+
+@deffn {Command Option} ---version
+prints version information and exit.
 @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 [R5RS], respectively.
+requires @var{feature}.  This will load a file from [SLIB] if that
+@var{feature} is not already provided.  If @var{feature} is 2, 2rs,
+r2rs, 3, 3rs, r3rs, 4, 4rs, r4rs, 5, 5rs, or r5rs; @code{scm} will
+require the features neccessary to support [R2RS], [R3RS], [R4RS], or
+[R5RS], respectively.
+@end deffn
+
+@deffn {Command Option} -h feature
+provides @var{feature}.
 @end deffn
 
 @deffn {Command Option} -l filename
 @deffnx {Command Option} -f filename
-loads @var{filename}. @code{Scm} will load the first (unoptioned) file
+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} -d filename
+Loads SLIB @code{databases} feature and opens @var{filename} as a
+database.
+@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} -o dumpname
+saves the current SCM session as the executable program @file{dumpname}.
+This option works only in SCM builds supporting @code{dump}
+(@pxref{Dump}).
+
+If options appear on the command line after @samp{-o @var{dumpname}},
+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} -p level
-sets the prolixity (verboseness) to @var{level}. This is the same as
+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
+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}.
+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 syntax-rules macro capability. To use a specific syntax-rules
+be with syntax-rules macro capability.  To use a specific syntax-rules
 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 syntax-rules macro capability. syntax-rules macro capability
+be without syntax-rules macro capability.  Syntax-rules 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
+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
+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
+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
@@ -1404,29 +1444,6 @@ treated as program aguments.
 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 Invocation Examples, SCM Variables, SCM Options, Operational Features
 @section Invocation Examples
 
@@ -1464,7 +1481,7 @@ Like above but @code{rev4-optional-procedures} are also loaded.
 
 @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@value{SCMVERSION}.scm} in the
+code.  The default is the file @file{Init@value{SCMVERSION}.scm} in the
 source directory.
 @end defvr
 
@@ -1485,22 +1502,22 @@ is not defined, the default is @samp{ed}.
 @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
+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*
+@defvar *syntax-rules*
 controls whether loading and interaction support syntax-rules
-macros. Define this in @file{ScmInit.scm} or files specified on the
-command line. This can be overridden by subsequent @code{-m} and
+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
+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
 
@@ -1529,6 +1546,12 @@ systems, SCM can also tail-call another program.  @xref{I/O-Extensions,
 execp}.
 @end defun
 
+@deffn {Callback procedure} boot-tail dumped?
+@code{boot-tail} is called by @code{scm_top_level} just before entering
+interactive top-level.  If @code{boot-tail} calls @code{quit}, then
+interactive top-level is not entered.
+@end deffn
+
 @defun program-arguments
 Returns a list of strings of the arguments scm was called with.
 @end defun
@@ -1699,7 +1722,7 @@ GNU Emacs.  PSD runs slowly, so start by instrumenting only a few
 functions at a time.
 @lisp
 http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz
-ftp.gnu.org:pub/gnu/jacal/slib-psd1-3.tar.gz
+swissnet.ai.mit.edu:/pub/scm/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
@@ -1953,14 +1976,16 @@ 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.
+messages bracketing file loading are printed.
 @item >= 3
-messages about heap growth are printed.
+the CPU time is printed after each top level form evaluated;
+notifications of heap growth printed.
 @item >= 4
-garbage collection (@pxref{Garbage Collection}) messages are printed.
+a garbage collection summary is printed after each top level form
+evaluated;
 @item >= 5
-a warning will be printed for each top-level symbol which is defined
-more than one time.
+a message for each GC (@pxref{Garbage Collection}) is printed;
+warnings issued for top-level symbols redefined.
 @end table
 @end defun
 
@@ -2070,7 +2095,7 @@ This combination of interpretatons allows SCM source files to be used as
 POSIX shell-scripts if the first line is:
 
 @example
-#!/usr/local/bin/scm \
+#! /usr/local/bin/scm \
 @end example
 
 @noindent
@@ -2189,7 +2214,7 @@ moved.
 
 @noindent
 The following approach solves these problems at the expense of slower
-startup.  Make @samp{#!/bin/sh} the first line and prepend every
+startup.  Make @samp{#! /bin/sh} the first line and prepend every
 subsequent line to be executed by the shell with @code{:;}.  The last
 line to be executed by the shell should contain an @dfn{exec} command;
 @code{exec} tail-calls its argument.
@@ -2253,6 +2278,7 @@ http://swissnet.ai.mit.edu/~jaffer/SLIB.html
 * Interrupts::                  and exceptions
 * Process Synchronization::     Because interrupts are preemptive
 * Files and Ports::             
+* Line Numbers::                
 * Soft Ports::                  Emulate I/O devices
 * Syntax Extensions::           
 * Low Level Syntactic Hooks::   
@@ -2396,9 +2422,10 @@ values returned by @code{current-input-port} and
 
 @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}.
+@code{try-load}, and @code{dyn:link}
+(@pxref{Compiling And Linking, , , hobbit, Hobbit}).
+@code{*load-pathname*} is used to compute the value of
+@ref{Vicinity, program-vicinity, , slib, SLIB}.
 @end defvar
 
 @defun line-number
@@ -2413,8 +2440,10 @@ not open to a file the result is unspecified.
 @defun port-line port
 @defunx port-column port
 If @var{port} is a tracked port, return the current line (column) number,
-otherwise return @code{#f}.  Line numbers begin with 1, the column number is
-zero if there are no characters on the current line.
+otherwise return @code{#f}.  Line and column numbers begin with 1.
+The column number applies to the next character to be read; if that
+character is a newline, then the column number will be one more than
+the length of the line.
 @end defun
 
 @defun eval obj
@@ -2581,9 +2610,77 @@ To unestablish a response for an error set the handler symbol to
 @code{#f}.  For instance, @code{(set! could-not-open #f)}.
 @end deffn
 
+@deffn {Callback procedure} gc-hook @dots{}
+Allows a Scheme procedure to be run shortly after each garbage collection.
+This procedure will not be run recursively.  If it runs long enough
+to cause a garbage collection before returning a warning will be
+printed.
+@end deffn
+
+@defun add-finalizer object finalizer
+@var{object} may be any garbage collected object, that is, any object
+other than an immediate integer, character, or special token such
+as @code{#f} or @code{#t}, @xref{Immediates}.  @var{finalizer} is
+a thunk, or procedure taking no arguments.
+
+@var{finalizer} will be invoked asynchronously exactly once some time
+after @var{object} becomes eligible for garbage collection.  A reference
+to @var{object} in the environment of @var{finalizer} will not prevent
+finalization, but will delay the reclamation of @var{object} at least
+until the next garbage collection.  A reference to @var{object} in some
+other object's finalizer will necessarily prevent finalization until both
+objects are eligible for garbage collection.
+
+Finalizers are not run in any predictable order.  All finalizers will be
+run by the time the program ends.
+
+This facility was based on the paper by Simon Peyton Jones, et al,
+``Stretching the storage manager: weak pointers and stable names in
+Haskell'', Proc. 11th International Workshop on the Implementation of
+Functional Languages, The Netherlands, September 7-10 1999,
+Springer-Verlag LNCS.
+
+@end defun
+
 @node Process Synchronization, Files and Ports, Interrupts, The Language
 @section Process Synchronization
 
+@noindent
+An @dfn{exchanger} is a procedure of one argument regulating mutually
+@cindex exchanger
+exclusive access to a resource.  When a exchanger is called, its current
+content is returned, while being replaced by its argument in an atomic
+operation.
+
+@defun make-exchanger obj
+
+Returns a new exchanger with the argument @var{obj} as its initial
+content.
+
+@example
+(define queue (make-exchanger (list a)))
+@end example
+
+A queue implemented as an exchanger holding a list can be protected from
+reentrant execution thus:
+
+@example
+(define (pop queue)
+  (let ((lst #f))
+    (dynamic-wind
+        (lambda () (set! lst (queue #f)))
+        (lambda () (and lst (not (null? lst))
+                        (let ((ret (car lst)))
+                          (set! lst (cdr lst))
+                          ret)))
+        (lambda () (and lst (queue lst))))))
+
+(pop queue)         @result{} a
+
+(pop queue)         @result{} #f
+@end example
+@end defun
+
 @defun make-arbiter name
 
 Returns an object of type arbiter and name @var{name}.  Its state is
@@ -2602,7 +2699,7 @@ 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
+@node Files and Ports, Line Numbers, Process Synchronization, The Language
 @section Files and Ports
 
 @noindent
@@ -2626,12 +2723,16 @@ Internal functions opening files @dfn{callback} to the SCM function
 @defvrx Constant open_both
 Contain modes strings specifying that a file is to be opened for
 reading, writing, and both reading and writing respectively.
+
+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 defvr
 
 @defun _ionbf modestr
 Returns a version of @var{modestr} which when @code{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 @code{char-ready?} and
+with it as the second argument will return an unbuffered port.  An
+input-port must be unbuffered in order for @code{char-ready?} and
 @code{wait-for-input} to work correctly on it.  The initial value of
 @code{(current-input-port)} is unbuffered if the platform supports it.
 @end defun
@@ -2640,20 +2741,28 @@ non-file input-port must be unbuffered in order for @code{char-ready?} and
 Returns a version of @var{modestr} which when @code{open-file} is called
 with it as the second argument will return a tracked port.  A tracked
 port maintains current line and column numbers, which may be queried
-with @code{port_line} and @code{port_column}.
+with @code{port-line} and @code{port-column}.
 @end defun
 
-@defun close-port port
-Closes @var{port}.  The same as close-input-port and close-output-port.
+@defun _exclusive modestr
+Returns a version of @var{modestr} which when @code{open-file} is called
+with it as the second argument will return a port only if the named file
+does not already exist.  This functionality is provided by calling
+@code{try-create-file} @xref{I/O-Extensions}, which is not available
+for all platforms.
+@end defun
+
+@defun port-closed? port
+Returns #t if @var{port} is closed.
 @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.
+@defun port-type obj
+If @var{obj} is not a port returns false, otherwise returns
+a symbol describing the port type, for example string or pipe.
+@end defun
+
+@defun close-port port
+Closes @var{port}.  The same as close-input-port and close-output-port.
 @end defun
 
 @defun current-error-port
@@ -2677,6 +2786,15 @@ and with-error-to-file in that the first argument is a port, rather
 than a string naming a file.
 @end defun
 
+@defun call-with-outputs thunk proc
+Calls the @var{thunk} procedure while the current-output-port and
+current-error-port are directed to string-ports.  If @var{thunk}
+returns, the @var{proc} procedure is called with the output-string, the
+error-string, and the value returned by @var{thunk}.  If @var{thunk}
+does not return a value (perhaps because of error), @var{proc} is called
+with just the output-string and the error-string as arguments.
+@end defun
+
 @deffn {procedure} char-ready?
 @deffnx {procedure} char-ready? port
 
@@ -2726,12 +2844,76 @@ Returns @code{#t} if @var{port} is input or output to a serial non-file device.
 Outputs a newline to optional argument @var{port} unless the current
 output column number of @var{port} is known to be zero, ie output will
 start at the beginning of a new line.  @var{port} defaults to
-@code{current-output-port}. If @var{port} is not a tracked port
+@code{current-output-port}.  If @var{port} is not a tracked port
 @code{freshline} is equivalent to @code{newline}.
 @end defun
 
+@defun open-ports
+Returns a list of all currently open ports, excluding string ports,
+see @xref{String Ports, , , slib, SLIB}.  This may be useful after
+a fork @xref{Posix Extensions}, or for debugging.  Bear in mind that
+ports that would be closed by gc will be kept open by a reference to
+this list.
+@end defun
+
+
+@node Line Numbers, Soft Ports, Files and Ports, The Language
+@section Line Numbers
+
+Scheme code define by load may optionally contain line number
+information.  Currently this information is used only for reporting
+expansion time errors, but in the future run-time error messages may
+also include line number information.
+
+@defun try-load pathname reader
+This is the primitive for loading, @var{pathname} is the name of 
+a file containing Scheme code, and optional argument @var{reader} is
+a function of one argument, a port.  @var{reader} should read and
+return Scheme code as list structure.  The default value is @code{read},
+which is used if @var{reader} is not supplied or is false.
+@end defun
+
+Line number objects are disjoint from integers or other Scheme types.
+When evaluated or loaded as Scheme code, an s-expression containing a
+line-number in the car is equivalent to the cdr of the s-expression.  A
+pair consisting of a line-number in the car and a vector in the cdr is
+equivalent to the vector.  The meaning of s-expressions with
+line-numbers in other positions is undefined.
 
-@node Soft Ports, Syntax Extensions, Files and Ports, The Language
+@defun read-numbered port
+Behaves like @code{read}, except that every s-expression read will be
+replaced with a cons of a line-number object and the sexp actually read.
+This replacement is done only if @var{port} is a tracked port
+See @xref{Files and Ports}.
+@end defun
+
+@defun integer->line-number int
+Returns a line-number object with value @var{int}.  @var{int} should
+be an exact non-negative integer.
+@end defun
+
+@defun line-number->integer linum
+Returns the value of line-number object @var{linum} as an integer.
+@end defun
+
+@defun line-number? obj
+Returns true if and only if @var{obj} is a line-number object.
+@end defun
+
+@defvar *load-reader*
+@defvarx *slib-load-reader*
+The value of @code{*load-reader*} should be a value acceptable as
+the second argument to @code{try-load} (note that #f is acceptable).
+This value will be used to read code during calls to @code{scm:load}.
+The value of @code{*slib-load-reader*} will similarly be used during
+calls to @code{slib:load} and @code{require}.
+
+In order to disable all line-numbering, it is sufficient to set!
+@code{*load-reader*} and @code{*slib-load-reader*} to #f.
+@end defvar
+
+
+@node Soft Ports, Syntax Extensions, Line Numbers, The Language
 @section Soft Ports
 
 @noindent
@@ -2766,6 +2948,9 @@ If thunk 3 returns @code{#f} or an @code{eof-object} (@pxref{Input,
 eof-object?, ,r5rs, Revised(5) Scheme}) it indicates that the port has
 reached end-of-file.  For example:
 
+If it is necessary to explicitly close the port when it is garbage
+collected, (@pxref{Interrupts, add-finalizer}).
+
 @example
 (define stdout (current-output-port))
 (define p (make-soft-port
@@ -2917,9 +3102,9 @@ is bound.  The result of the @samp{set!} expression is unspecified.
 @end example
 @end defspec
 
-@defspec casev key clause1 clause2 @dots{}
-@code{casev} is an extension of standard Scheme @code{case}: Each
-@var{clause} of a @code{casev} statement must have as first element a
+@defspec qase key clause1 clause2 @dots{}
+@code{qase} is an extension of standard Scheme @code{case}: Each
+@var{clause} of a @code{qase} statement must have as first element a
 list containing elements which are:
 
 @itemize @bullet
@@ -2932,7 +3117,7 @@ a comma followed by an at-sign (@@) followed by the name of a symbolic
 constant whose value is a list.
 @end itemize
 
-A @code{casev} statement is equivalent to a @code{case} statement in
+A @code{qase} statement is equivalent to a @code{case} statement in
 which these symbolic constants preceded by commas have been replaced by
 the values of the constants, and all symbolic constants preceded by
 comma-at-signs have been replaced by the elements of the list values of
@@ -2941,20 +3126,20 @@ similar to that of @code{quasiquote} except that the unquoted
 expressions must be @dfn{symbolic constants}.
 
 Symbolic constants are defined using @code{defconst}, their values are
-substituted in the head of each @code{casev} clause during macro
+substituted in the head of each @code{qase} clause during macro
 expansion.  @code{defconst} constants should be defined before use.
-@code{casev} can be substituted for any correct use of @code{case}.
+@code{qase} can be substituted for any correct use of @code{case}.
 
 @format
 @t{(defconst unit '1)
 (defconst semivowels '(w y))
-(casev (* 2 3)
+(qase (* 2 3)
   ((2 3 5 7) 'prime)
   ((,unit 4 6 8 9) 'composite))        ==>  composite
-(casev (car '(c d))
+(qase (car '(c d))
   ((a) 'a)
   ((b) 'b))                            ==>  @emph{unspecified}
-(casev (car '(c d))
+(qase (car '(c d))
   ((a e i o u) 'vowel)
   ((,@@semivowels) 'semivowel)
   (else 'consonant))                   ==>  consonant
@@ -2964,10 +3149,97 @@ expansion.  @code{defconst} constants should be defined before use.
 @end defspec
 
 @noindent
+@findex defmacro
+@findex macroexpand
+@findex macroexpand-1
+@findex gentemp
 SCM also supports the following constructs from Common Lisp:
 @code{defmacro}, @code{macroexpand}, @code{macroexpand-1}, and
 @code{gentemp}.  @xref{Defmacro, , , slib, SLIB}.
 
+SCM @code{defmacro} is extended over that described for SLIB:
+
+@lisp
+(defmacro (macro-name . arguments) body)
+@end lisp
+
+is equivalent to
+
+@lisp
+(defmacro macro-name arguments body)
+@end lisp
+
+As in Common Lisp, an element of the formal argument list for
+@code{defmacro} may be a possibly nested list, in which case the
+corresponding actual argument must be a list with as many members as the
+formal argument.  Rest arguments are indicated by improper lists, as in
+Scheme.  It is an error if the actual argument list does not have the
+tree structure required by the formal argument list.
+
+For example:
+
+@lisp
+(defmacro (let1 ((name value)) . body)
+    `((lambda (,name) ,@@body) ,value))
+
+(let1 ((x (foo))) (print x) x) @equiv{} ((lambda (x) (print x) x) (foo))
+
+(let1 not legal syntax) @error{} not "does not match" ((name value))
+@end lisp
+
+@findex syntax-rules
+SCM supports [R5RS] @code{syntax-rules} macros
+@xref{Macros, , ,r5rs, Revised(5) Scheme}.
+
+The pattern language is extended by the syntax @code{(... <obj>)}, which
+is identical to @code{<obj>} except that ellipses in @code{<obj>} are
+treated as ordinary identifiers in a template, or as literals in a
+pattern.  In particular, @code{(... ...)} quotes the ellipsis token
+@code{...} in a pattern or template.
+
+For example:
+@lisp
+(define-syntax check-tree
+  (syntax-rules ()
+    ((_ (?pattern (... ...)) ?obj)
+     (let loop ((obj ?obj))
+       (or (null? obj)
+           (and (pair? obj)
+                (check-tree ?pattern (car obj))
+                (loop (cdr obj))))))
+    ((_ (?first . ?rest) ?obj)
+     (let ((obj ?obj))
+       (and (pair? obj)
+            (check-tree ?first (car obj))
+            (check-tree ?rest (cdr obj)))))
+    ((_ ?atom ?obj) #t)))
+
+(check-tree ((a b) ...) '((1 2) (3 4) (5 6))) @result{} #t
+
+(check-tree ((a b) ...) '((1 2) (3 4) not-a-2list) @result{} #f
+@end lisp
+
+Note that although the ellipsis is matched as a literal token in the
+defined macro it is not included in the literals list for
+@code{syntax-rules}.
+
+The pattern language is also extended to support identifier macros.  A
+reference to an identifier macro keyword that is not the first
+identifier in a form may expand into Scheme code, rather than raising a
+``keyword as variable'' error.  The pattern for expansion of such a bare
+macro keyword is a single identifier, as in other syntax rules the
+identifier is ignored.
+
+For example:
+@lisp
+(define-syntax eight
+    (syntax-rules ()
+      (_ 8)))
+
+(+ 3 eight) @result{} 11
+(eight) @result{} ERROR
+(set! eight 9) @result{} ERROR
+@end lisp
 
 @node Low Level Syntactic Hooks, Syntactic Hooks for Hygienic Macros, Syntax Extensions, The Language
 @section Low Level Syntactic Hooks
@@ -2998,7 +3270,6 @@ 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}).
 
-
 @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
@@ -3007,6 +3278,7 @@ as the first symbol in an expression, returns the result of applying
 
 @defun procedure->macro proc
 @defunx procedure->memoizing-macro proc
+@defunx procedure->identifier-macro
 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
@@ -3015,19 +3287,34 @@ from @var{proc} which has been passed to
 @var{proc}.  For example:
 
 @example
-(define trace
+(defsyntax 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
+
+@code{PROCEDURE->IDENTIFIER-MACRO} is similar to
+@code{PROCEDURE->MEMOIZING-MACRO} except that @var{proc} is also
+called in case the symbol bound to the macro appears in an expression
+but @emph{not} as the first symbol, that is, when it looks like a
+variable reference.  In that case, the form passed to @var{proc} is
+a single identifier.
+
 @end defun
 
-@defun environment->tree env
-An @dfn{environment} is an opaque object representing lexical bindings.
-@code{environment->tree} returns a representation of the environment
-@var{env} as a list of environment frames.  There are 2 types of
-environment frames:
+@defspec defsyntax name expr
+Defines @var{name} as a macro keyword bound to the result of evaluating
+@var{expr}, which should be a macro.  Using @code{define} for this
+purpose may not result in @var{name} being interpreted as a macro
+keyword.
+@end defspec
+
+An @dfn{environment} is a list of frames representing lexical bindings.
+Only the names and scope of the bindings are included in environments
+passed to macro expanders -- run-time values are not included.
+
+There are several types of environment frames:
 
 @table @code
 @item ((lambda (variable1 @dots{}) @dots{}) value1 @dots{})
@@ -3035,17 +3322,58 @@ environment frames:
 @itemx (letrec ((variable1 value1)  @dots{}) @dots{})
 result in a single enviroment frame:
 @example
-((variable1 @dots{}) value1 @dots{})
+
+(variable1 variable2 @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{}
+
+variable1 variable2 @dots{}
+
 @end example
+
+@item (let-syntax ((key1 macro1) (key2 macro2)) @dots{})
+@itemx (letrec-syntax ((key1 value1) (key2 value2)) @dots{})
+Lexically bound macros result in environment frames consisting of
+a marker and an alist of keywords and macro objects:
+@example
+
+(<env-syntax-marker> (key1 . value1) (key2 . value2))
+
+@end example
+Currently <env-syntax-marker> is the integer 6.
+
+@item line numbers
+Line numbers (@pxref{Line Numbers}) may be included in the environment
+as frame entries to indicate the line number on which a function is
+defined.  They are ignored for variable lookup.
+@example
+
+#<line 8> 
+
+@end example
+
+@item miscellaneous
+Debugging information is stored in environments in a plist format: Any
+exact integer stored as an environment frame may be followed by any
+value.  The two frame entries are ignored when doing variable lookup.
+Load file names, procedure names, and closure documentation strings
+are stored in this format.
+@example
+
+<env-filename-marker> "foo.scm" <env-procedure-name-marker> foo @dots{}
+
+@end example
+
+Currently <env-filename-marker> is the integer 1 and
+<env-procedure-name-marker> the integer 2.
+
+
 @end table
-@end defun
 
 @defspec @@apply procedure argument-list
 Returns the result of applying @var{procedure} to @var{argument-list}.
@@ -3063,15 +3391,6 @@ Thus a mutable environment can be treated as both a list and local
 bindings.
 @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 Syntactic Hooks for Hygienic Macros,  , Low Level Syntactic Hooks, The Language
 @section Syntactic Hooks for Hygienic Macros
 
@@ -3124,7 +3443,8 @@ Returns the symbol obtained by recursively extracting the parent of
 
 If an identifier returned by this version of @code{gentemp} is inserted
 in a binding position as the name of a variable then it is guaranteed
-that no other identifier may denote that variable.  If an identifier
+that no other identifier (except one produced by passing the first to
+@code{renamed-identifier}) may denote that variable.  If an identifier
 returned by @code{gentemp} is inserted free, then it will denote the
 top-level value bound to its parent, the symbol named ``An unlikely
 variable''.  This behavior, of course, is meant to be put to good use:
@@ -3155,17 +3475,10 @@ be restricted to the lexical scope of its environment.
 
 There is another restriction imposed for implementation convenience:
 Macros passing their lexical environments to @code{renamed-identifier}
-may be lexically bound only by the special forms @code{@@let-syntax} or
-@code{@@letrec-syntax}.  No error is signaled if this restriction is not
+may be lexically bound only by the special forms @code{let-syntax} or
+@code{letrec-syntax}.  No error is signaled if this restriction is not
 met, but synthetic identifier lookup will not work properly.
 
-@defspec @@let-syntax
-@defspecx @@letrec-syntax
-Behave as @code{let} and @code{letrec}, but may also put extra
-information in the lexical environment so that @code{renamed-identifier}
-will work properly during expansion of the macros bound by these forms.
-@end defspec
-
 In order to maintain referential transparency it is necessary to
 determine whether two identifiers have the same denotation.  With
 synthetic identifiers it is not necessary that two identifiers be
@@ -3174,8 +3487,8 @@ synthetic identifiers it is not necessary that two identifiers be
 @defun identifier-equal? id1 id2 env
 Returns @code{#t} if identifiers @var{id1} and @var{id2} denote the same
 binding in lexical environment @var{env}, and @code{#f} otherwise.
-@var{env} must be a lexical environment passed to a macro transformer
-during macro expansion.
+@var{env} must either be a lexical environment passed to a macro transformer
+during macro expansion or the empty list.
 
 For example,
 @lisp
@@ -3240,7 +3553,7 @@ proposed by W. Clinger [Exrename] is supported.  Syntax may be defined
 in @code{define-syntax}, @code{let-syntax}, and @code{letrec-syntax}
 using @code{renaming-transformer} instead of @code{syntax-rules}.
 @var{proc} should evaluate to a procedure accepting three arguments:
-@var{expr}, @var{rename}, and @var{compare}. @var{expr} is a
+@var{expr}, @var{rename}, and @var{compare}.  @var{expr} is a
 representation of Scheme code to be expanded, as list structure.
 @var{rename} is a procedure accepting an identifier and returning an
 identifier renamed in the definition environment of the new syntax.
@@ -3252,72 +3565,47 @@ both denote the same binding in the usage environment of the new syntax.
 @chapter Packages
 
 @menu
-* Compiling And Linking::       Hobbit
 * Dynamic Linking::             
 * Dump::                        Create Fast-Booting Executables
 * Numeric::                     Numeric Language Extensions
 * Arrays::                      As in APL
+* Records::                     Define new aggregate data types
 * I/O-Extensions::              i/o-extensions
 * Posix Extensions::            posix
+* Unix Extensions::             non-posix unix
 * Regular Expression Pattern Matching::  regex
 * Line Editing::                edit-line
 * Curses::                      Screen Control
 * Sockets::                     Cruise the Net
 @end menu
 
+@cindex Xlib
+@cindex Xlibscm
+@cindex xlib
+@cindex xlibscm
+@cindex x
+@cindex X
+@cindex graphics
+@cindex hobbit
 @menu
 * Xlib: (Xlibscm).              X Window Graphics.
+* Hobbit: (hobbit).             Scheme-to-C Compiler.
 @end menu
 
-@node Compiling And Linking, Dynamic Linking, Packages, 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
+@iftex
+@section hobbit
 
-@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}.
+@ifset html
+<A HREF="hobbit_toc.html">
+@code{(require 'compile)}
 
-@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@value{SCMVERSION}.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
+@dfn{hobbit}
+</A>
+is a SCM->C compiler.
+@end ifset
+@end iftex
 
-@node Dynamic Linking, Dump, Compiling And Linking, Packages
+@node Dynamic Linking, Dump, Packages, Packages
 @section Dynamic Linking
 
 @noindent
@@ -3492,10 +3780,12 @@ dump is the last expression in that file.
 @item
 Calls @code{gc}.
 @item
+@findex boot-tail
 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.
+@var{thunk}, if provided, should be a procedure of no arguments;
+@var{boot-tail} will be set to this procedure, causing it to 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.
@@ -3527,10 +3817,6 @@ arguments for the curent invocation.  More specifically,
 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.
@@ -3574,10 +3860,23 @@ The immediate integer closest to positive infinity.
 The immediate integer closest to negative infinity.
 @end defvr
 
+@defvr Constant $pi
+@defvrx Constant pi
+The ratio of the circumference to the diameter of a circle.
+@end defvr
+
 @noindent
 These procedures augment the standard capabilities in @ref{Numerical
 operations, , ,r5rs, Revised(5) Scheme}.
 
+@defun pi* z
+@code{(* pi @var{z})}
+@end defun
+
+@defun pi/ z
+@code{(/ pi @var{z})}
+@end defun
+
 @defun sinh z
 @defunx cosh z
 @defunx tanh z
@@ -3627,7 +3926,7 @@ 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
+@node Arrays, Records, Numeric, Packages
 @section Arrays
 
 @menu
@@ -3765,7 +4064,7 @@ Returns a list of inclusive bounds of integers.
 
 @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:
+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
@@ -3811,7 +4110,7 @@ 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{create-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
@@ -3864,7 +4163,7 @@ One can implement @var{array-indexes} as
 Another example:
 @example
 (define (apl:index-generator n)
-    (let ((v (make-uniform-vector n 1)))
+    (let ((v (make-vector n 1)))
       (array-index-map! v (lambda (i) i))
       v))
 @end example
@@ -3880,6 +4179,7 @@ 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
 
@@ -3889,28 +4189,14 @@ 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)                    #At
-#\a             char (string)                           #A\
-integer >0      unsigned integer                        #Au
-integer <0      signed integer                          #Ae
-1.0             float (single precision)                #Aif
-1/3             double (double precision float)         #Aid
-+i              complex (double precision)              #Aic
-()              conventional vector                     #A
-@end example
+SLIB now supports uniform arrys.  The primary array creation procedure
+is @code{create-array}, detailed in @xref{Arrays, , , slib, SLIB}.
 
 @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"
+(create-array "" 3) @result{} "$q2"
 @end example
 
 @noindent
@@ -3918,7 +4204,7 @@ 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
+(create-array '#at() 3) @result{} #*000
 @equiv{}
 #At(#f #f #f) @result{} #*000
 @equiv{}
@@ -3926,39 +4212,41 @@ bit-vectors}.
 @end example
 
 @noindent
-Other uniform vectors are written in a form similar to that of general
-arrays, except that one or more modifying characters are put between
-the #\A character and the contents list.  For example, @code{'#Ae(3 5 9)}
-returns a uniform vector of signed integers.
+@var{prototype} arguments in the following procedures are interpreted
+according to the table:
 
-@defun uniform-vector-ref uve index
-Returns the element at the @var{index} element in @var{uve}.
-@end defun
+@example
+prototype       type                              display prefix
+
+()              conventional vector                     #a
++64i            complex (double precision)              #ac64
+64.0            double (double precision)               #ar64
+32.0            float (single precision)                #ar32
+32              unsigned integer (32-bit)               #au32
+-32             signed integer (32-bit)                 #as32
+-16             signed integer (16-bit)                 #as16
+#\a             char (string)                           #a\
+#t              boolean (bit-vector)                    #at
+@end example
 
-@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
+@noindent
+Other uniform vectors are written in a form similar to that of general
+arrays, except that one or more modifying characters are put between the
+#\A character and the contents list.  For example, @code{'#As32(3 5 9)}
+returns a uniform vector of signed integers.
 
 @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.
-@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}.
+@code{list->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.
@@ -3977,14 +4265,8 @@ 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
@@ -3993,8 +4275,6 @@ this value.
 
 @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}
@@ -4008,10 +4288,8 @@ returned by @code{(current-input-port)}.
 
 @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
+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
@@ -4043,7 +4321,6 @@ if the array element is not an exact integer or if @var{val} is not
 boolean.
 @end defun
 
-
 @node Bit Vectors,  , Uniform Array, Arrays
 @subsection Bit Vectors
 
@@ -4093,8 +4370,26 @@ Returns
 @var{bv} is not modified.
 @end defun
 
+@node Records, I/O-Extensions, Arrays, Packages
+@section Records
+
+SCM provides user-definable datatypes with the same interface as SLIB,
+see @xref{Records, , , slib, SLIB}, with the following extension.
+
+@defun record-printer-set! rtd printer
+Causes records of type @var{rtd} to be printed in a user-specified format.
+@var{rtd} must be a record type descriptor returned by @code{make-record-type},
+@var{printer} a procedure accepting three arguments:  the record to be printed,
+the port to print to, and a boolean which is true if the record is being
+written on behalf of @code{write} and false if for @code{display}.
+If @var{printer} returns #f, the default record printer will be called.
 
-@node I/O-Extensions, Posix Extensions, Arrays, Packages
+A @var{printer} value of #f means use the default printer.
+
+Only the default printer will be used when printing error messages.
+@end defun
+
+@node I/O-Extensions, Posix Extensions, Records, Packages
 @section I/O-Extensions
 
 @noindent
@@ -4103,7 +4398,7 @@ If @code{'i/o-extensions} is provided (by linking in @file{ioext.o}),
 
 @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
+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
@@ -4154,6 +4449,14 @@ written.  If @var{port} is not open to a file the action of
 @code{file-set-position} is unspecified.
 @end defun
 
+@defun try-create-file name modes perms
+If the file with name @var{name} already exists, return @code{#f},
+otherwise try to create and open the file like @code{try-open-file},
+@xref{Files and Ports}.  If the optional integer argument @var{perms} is
+provided, it is used as the permissions of the new file (modified by
+the current umask).
+@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,
@@ -4333,7 +4636,7 @@ Like @code{execl} and @code{execlp} except that the set of arguments to
 @end defun
 
 @defun putenv string
-adds or removes definitions from the @dfn{environment}. If the
+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
@@ -4351,7 +4654,7 @@ 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
+@node Posix Extensions, Unix Extensions, I/O-Extensions, Packages
 @section Posix Extensions
 
 @noindent
@@ -4379,6 +4682,15 @@ the standard input of the system command @var{string}.  If a pipe cannot
 be created @code{#f} is returned.
 @end defun
 
+@defun broken-pipe port
+If this function is defined at top level, it will be called when an
+output pipe is closed from the other side (this is the condition under
+which a SIGPIPE is sent).  The already closed @var{port} will be passed
+so that any necessary cleanup may be done.  An error is not signaled
+when output to a pipe fails in this way, but any further output to
+the closed pipe will cause an error to be signaled.
+@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
@@ -4406,6 +4718,11 @@ 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 getlogin
+Returns the (login) name of the user logged in on the controlling
+terminal of the process, or #f if this information cannot be determined.
+@end defun
+
 @defun getuid
 Returns the real user ID of this process.
 @end defun
@@ -4531,12 +4848,13 @@ stopped, and whose status has not been reported.
 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}.
+The return value normally is the exit status of the child process,
+including the exit value along with flags indicating whether a coredump
+was generated or the child terminated as a result of a signal.  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
@@ -4653,6 +4971,7 @@ string containing the file name of termainal device; otherwise
 @code{#f}.
 @end defun
 
+@node Unix Extensions, Regular Expression Pattern Matching, Posix Extensions, Packages
 @section Unix Extensions
 
 @noindent
@@ -4660,7 +4979,7 @@ 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:
+These @dfn{privileged} and symbolic link functions are not in Posix:
 
 @defun symlink oldname newname
 The @code{symlink} function makes a symbolic link to @var{oldname} named
@@ -4690,7 +5009,7 @@ Increment the priority of the current process by @var{increment}.
 
 @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
+turned on, records for each terminating process are appended to
 @var{filename} as it terminates.  An argument of @code{#f} causes
 accounting to be turned off.
 
@@ -4712,7 +5031,8 @@ 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
+
+@node Regular Expression Pattern Matching, Line Editing, Unix Extensions, Packages
 @section Regular Expression Pattern Matching
 
 These functions are defined in @file{rgx.c} using a POSIX or GNU
@@ -4728,7 +5048,7 @@ 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
+control the compilation of the regular expression.  The letters may
 consist of:
 
 @table @samp
@@ -4796,7 +5116,7 @@ a list of a string and a set of option letters.
 @item string
 The string to be operated upon.
 @item start
-The character position at which to begin the search or match. If absent,
+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:}
@@ -4807,7 +5127,7 @@ 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.
+@var{string}.  If absent, the entire string may be examined.
 @end table
 @end defun
 
@@ -4981,7 +5301,7 @@ terminal, it is also necessary to call @code{idlok}.
 
 @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
+ready, wgetch will return an eof-object.  If disabled, wgetch will hang
 until a key is pressed.
 @end defun
 
@@ -5528,7 +5848,7 @@ successful.
 @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{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}).
@@ -6011,6 +6331,10 @@ uniform vector of integers
 uniform vector of non-negative integers
 @end deftp
 
+@deftp Header tc7_svect
+uniform vector of short integers
+@end deftp
+
 @deftp Header tc7_fvect
 uniform vector of short inexact real numbers
 @end deftp
@@ -6343,7 +6667,7 @@ bvect   .........long length....G0010101  ..........long *words...........
 ivect   .........long length....G0011101  ..........long *words...........
 uvect   .........long length....G0011111  ......unsigned long *words......
  spare                          G0100101
- spare                          G0100111
+svect   .........long length....G0100111  ........ short *words...........
 fvect   .........long length....G0101101  .........float *words...........
 dvect   .........long length....G0101111  ........double *words...........
 cvect   .........long length....G0110101  ........double *words...........
@@ -6459,7 +6783,7 @@ unmarked, gc_mark sets the mark bit in @var{obj}, then calls
 @code{gc_mark()} is tail-called (looped).
 @end deftypefun
 
-@deftypefun void mark_locations (STACKITEM @var{x[]}, sizet @var{len}))
+@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
@@ -6499,6 +6823,9 @@ object is freed.  If the type header of smob is collected, the smob's
 @node Memory Management for Environments, Signals, Garbage Collection, Operations
 @subsection Memory Management for Environments
 
+@cindex memory management
+@cindex environments
+@cindex ecache
 @itemize @bullet
 @item
 @dfn{Ecache} was designed and implemented by Radey Shouman.
@@ -6592,6 +6919,7 @@ and swept almost like any ordinary segment of the general purpose
 heap.  The only difference is that pairs from the copying heap that
 become free during a sweep phase are not added to the freelist.
 
+@cindex NO_ENV_CACHE
 The environment cache is disabled by adding @code{#define NO_ENV_CACHE}
 to @file{eval.c}; all environment cells are then allocated from the
 regular heap.
@@ -6958,9 +7286,10 @@ free0(ptr) is provided which does not free any storage and returns 0.
 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).
+be @code{write}n, 0 if it should be @code{display}ed, and 2 if it should
+be @code{write}n for an error report.  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
@@ -7024,7 +7353,7 @@ The following functions are provided for that purpose:
 @deftypefunx {char *} must_malloc (long @var{len}, char *@var{what})
 @var{len} is the number of bytes that should be allocated, @var{what} is
 a string to be used in error or gc messages.  @code{must_malloc} returns
-a pointer to newly allocated memory. @code{must_malloc_cell} returns a
+a pointer to newly allocated memory.  @code{must_malloc_cell} returns a
 newly allocated cell whose @code{car} is @var{c} and whose @code{cdr} is
 a pointer to newly allocated memory.
 @end deftypefun
@@ -7039,7 +7368,7 @@ argument @var{where} the address of a block of memory of length @var{olen}
 allocated by @code{must_malloc} and returns the address of a block of 
 length @var{len}.
 
-The contents of the reallocated block will be unchanged up the the
+The contents of the reallocated block will be unchanged up to the
 minimum of the old and new sizes.
 
 @var{what} is a pointer to a string used for error and gc messages.
@@ -7047,7 +7376,9 @@ minimum of the old and new sizes.
 
 @code{must_malloc}, @code{must_malloc_cell}, @code{must_realloc}, and
 @code{must_realloc_cell} must be called with interrupts deferred
-@xref{Signals}.
+@xref{Signals}.  @code{must_realloc} and @code{must_realloc_cell} must
+not be called during initialization (non-zero errjmp_bad) -- the initial
+allocations must be large enough.
 
 @deftypefun void must_free (char *@var{ptr}, sizet @var{len})
 @code{must_free} is used to free a block of memory allocated by the
@@ -7251,7 +7582,7 @@ int main(argc, argv)
   fprintf(stderr, "dld_find_executable(%s): %s\n", argv[0], execpath);
   implpath = find_impl_file(execpath, "scm", INIT_FILE_NAME, dirsep);
   fprintf(stderr, "implpath: %s\n", implpath);
-  scm_init_from_argv(argc, argv, 0, 0);
+  scm_init_from_argv(argc, argv, 0L, 0, 0);
 
   retval = scm_top_level(implpath, user_main);
 
diff --git a/scmfig.h b/scmfig.h
index 99d4f21..a87e928 100644
--- a/scmfig.h
+++ b/scmfig.h
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -47,7 +47,9 @@
 # define strchr index
 # define strrchr rindex
 #else
-# include <string.h>
+# ifndef PLAN9
+#  include <string.h>
+# endif
 #endif
 
 #include "scmflags.h"		/* user specified, system independent flags */
@@ -106,7 +108,7 @@ rgx.c	init_rgx();	regcomp and regexec. */
 #  define CDR_DOUBLES
 # endif
 
-# ifdef _UNICOS          /* doubles are no better than singles on Cray. */
+# ifdef _UNICOS		/* doubles are no better than singles on Cray. */
 #  define SINGLESONLY
 # endif
 
@@ -211,7 +213,7 @@ rgx.c	init_rgx();	regcomp and regexec. */
 #endif
 /* added by Denys Duchier */
 #ifndef SVR4
-# ifdef __svr4__
+# ifdef __SVR4
 #  define SVR4
 # endif
 #endif
@@ -262,6 +264,7 @@ rgx.c	init_rgx();	regcomp and regexec. */
 #endif
 #ifdef _WIN32
 # define MSDOS
+# define LACK_SBRK
 # define LACK_TIMES
 #endif
 #ifdef _MSDOS
@@ -297,13 +300,17 @@ rgx.c	init_rgx();	regcomp and regexec. */
 # define STDC_HEADERS
 # define USE_ANSI_PROTOTYPES
 # define HAVE_SYS_TIME_H
-# define __svr4__
+# define __SVR4
 #endif
 
-#ifdef __svr4__
+#ifdef __SVR4
 # define HAVE_SELECT
 #endif
 
+#ifdef PLAN9
+# define STDC_HEADERS
+#endif
+
 #ifdef hpux
 # define LACK_E_IDs
 #endif
@@ -312,6 +319,7 @@ rgx.c	init_rgx();	regcomp and regexec. */
 #ifdef __IBMC__
 # define STDC_HEADERS
 # define LACK_TIMES
+# define LACK_SBRK
 #endif
 
 #ifdef __CYGWIN32__
@@ -321,7 +329,7 @@ rgx.c	init_rgx();	regcomp and regexec. */
 # undef MSDOS
 #endif
 
-#ifdef __amigados__
+#ifdef __amigaos__
 # define HAVE_SELECT
 # define HAVE_SYS_TIME_H
 # define LACK_SBRK
@@ -409,26 +417,26 @@ rgx.c	init_rgx();	regcomp and regexec. */
 # define ALLOW_INTS_EGC /**/
 #else
 # ifdef CAREFUL_INTS
-typedef struct {char *fname; long linum;} ints_infot;
+typedef struct {char *fname; int linum;} ints_infot;
 extern ints_infot *ints_info;
 #  define VERIFY_INTS(s1, s2) {if (!ints_disabled)\
-     ints_warn(s1, s2, __FILE__,__LINE__); }
+     ints_warn(s1, s2, __FILE__, __LINE__); }
 #  define DEFER_INTS \
    {static ints_infot info = {__FILE__, __LINE__};\
      FENCE;if (1==ints_disabled) ints_viol(&info, 1);\
-           else {ints_info = &info; ints_disabled = 1;FENCE;}}
+	   else {ints_info = &info; ints_disabled = 1;FENCE;}}
 #  define ALLOW_INTS \
    {static ints_infot info = {__FILE__, __LINE__};\
     FENCE;if (1!=ints_disabled) ints_viol(&info, 0);\
-          else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
+	  else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
 #  define DEFER_INTS_EGC \
    {static ints_infot info = {__FILE__, __LINE__};\
     FENCE;if (1==ints_disabled) ints_viol(&info, 1);\
-          else {ints_info = &info; ints_disabled = 2;FENCE;}}
+	  else {ints_info = &info; ints_disabled = 2;FENCE;}}
 #  define ALLOW_INTS_EGC \
    {static ints_infot info = {__FILE__, __LINE__};\
     FENCE;if (1==ints_disabled) ints_viol(&info, 0);\
-          else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
+	  else {ints_info = &info; ints_disabled = 0;FENCE;CHECK_INTS}}
 # else
 #  define VERIFY_INTS(s1, s2) /**/
 #  define DEFER_INTS {FENCE;ints_disabled = 1;FENCE;}
@@ -462,8 +470,14 @@ extern ints_infot *ints_info;
 # define PTR2SCM(x) (((SCM)(x)) << 3)
 # define POINTERS_MUNGED
 #else
-# define SCM2PTR(x) (x)
-# define PTR2SCM(x) ((SCM)(x))
+# ifdef TEST_SCM2PTR
+#  define SCM2PTR(x) ((x) ^ 0xf0L)
+#  define PTR2SCM(x) (((SCM)(x)) ^ 0xf0L)
+#  define POINTERS_MUNGED
+# else
+#  define SCM2PTR(x) (x)
+#  define PTR2SCM(x) ((SCM)(x))
+# endif
 #endif
 
 /* FIXABLE is non-null if its long argument can be encoded in an INUM. */
@@ -576,7 +590,9 @@ extern ints_infot *ints_info;
 #ifdef FLOATS
 # ifdef STDC_HEADERS
 #  ifndef macintosh
-#   include <float.h>
+#   ifndef PLAN9
+#    include <float.h>
+#   endif
 #  endif
 # endif
 # ifdef DBL_MAX_10_EXP
@@ -597,12 +613,19 @@ extern ints_infot *ints_info;
 # endif
 #endif
 
-/* Only some machines have pipes */
+#ifdef unix
+# define HAVE_UNIX
+#endif
+#ifdef __unix__
+# define HAVE_UNIX
+#endif
 #ifdef _IBMR2
-# define unix
+# define HAVE_UNIX
 # define STDC_HEADERS
 #endif
-#ifdef unix
+
+/* Only some machines have pipes */
+#ifdef HAVE_UNIX
   /* DJGPP (gcc for i386) defines unix! */
 # define HAVE_PIPE
 #endif
@@ -644,12 +667,20 @@ typedef SCM  *SCMPTR;
 # 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))
+
 #ifdef STDC_HEADERS
-# include <stdlib.h>
-# ifdef AMIGA
-#  include <stddef.h>
+# ifdef PLAN9
+#  define sizet long
+# else
+#  include <stdlib.h>
+#  ifdef AMIGA
+#   include <stddef.h>
+#  endif
+#  define sizet size_t
 # endif
-# define sizet size_t
 #else
 # ifdef _SIZE_T
 #  define sizet size_t
@@ -665,7 +696,9 @@ typedef SCM  *SCMPTR;
 /* On VMS, GNU C's errno.h contains a special hack to get link attributes
    for errno correct for linking with libc. */
 
-#include <errno.h>
+#ifndef PLAN9
+# include <errno.h>
+#endif
 
 /* SYSCALL retries system calls that have been interrupted (EINTR) */
 #ifdef vms
@@ -691,15 +724,19 @@ typedef SCM  *SCMPTR;
 #define SYSCALL(line) do{errno = 0;line}while(SCM_INTERRUPTED(errno))
 
 #ifdef EMFILE
-# define SCM_NEED_FDS(errno) (EMFILE==errno || ENFILE==errno)
+# ifdef ENFILE
+#  define SCM_NEED_FDS(errno) (EMFILE==errno || ENFILE==errno)
+# else
+#  define SCM_NEED_FDS(errno) (EMFILE==errno)
+# endif
 #else
 # define SCM_NEED_FDS(errno) (0)
 #endif
 
 #define SCM_OPENCALL(line) {int gcs = 0;\
-                             while (!0) {errno = 0; if (line) break;\
-                             if (0==gcs++ && SCM_NEED_FDS(errno)) \
-                               gc_for_open_files();\
+			     while (!0) {errno = 0; if (line) break;\
+			     if (0==gcs++ && SCM_NEED_FDS(errno)) \
+			       gc_for_open_files();\
 			      else if (!SCM_INTERRUPTED(errno)) break;}}
 
 #ifndef MSDOS
@@ -751,4 +788,12 @@ typedef SCM  *SCMPTR;
 # define VOLATILE /**/
 #endif
 
+#ifdef _MSC_VER
+				// Disable annoying warnings for:
+# pragma warning (disable: 4102) // unreferenced label
+# pragma warning (disable: 4018) // signed/unsigned mismatch
+# pragma warning (disable: 4101) // unreferenced variables
+# pragma warning (disable: 4244) // conversion from unsigned long to unsigned short
+#endif
+
 /* end of automatic C pre-processor definitions */
diff --git a/scmhob.h b/scmhob.h
new file mode 100644
index 0000000..b1480c1
--- /dev/null
+++ b/scmhob.h
@@ -0,0 +1,105 @@
+/*   scmhob.h is a header file for scheme source compiled with hobbit5x
+     Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet 
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+*/
+
+#include "scm.h"
+
+#define STBL_VECTOR_SET(v,k,o) (v[((long)INUM(k))] = o)
+#define STBL_VECTOR_REF(v,k) (v[((long)INUM(k))])
+#define CHAR_LESSP(x,y) ((ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F)
+#define CHAR_LEQP(x,y) ((ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F)
+#define CHCI_EQ(x,y) ((upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
+#define CHCI_LESSP(x,y) ((upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
+#define CHCI_LEQP(x,y) ((upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
+#define CHAR_ALPHAP(chr) ((isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F)
+#define CHAR_NUMP(chr) ((isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F)
+#define CHAR_WHITEP(chr) ((isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F)
+#define CHAR_UPPERP(chr) ((isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F)
+#define CHAR_LOWERP(chr) ((isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F)
+#define CHAR2INT(chr) MAKINUM(ICHR(chr))
+#define INT2CHAR(n) MAKICHR(INUM(n))
+#define CHAR_UPCASE(chr) MAKICHR(upcase[ICHR(chr)])
+#define CHAR_DOWNCASE(chr) MAKICHR(downcase[ICHR(chr)])
+#define ST_LENGTH(str) MAKINUM(LENGTH(str))
+#define ST_REF(str,k) MAKICHR(CHARS(str)[INUM(k)])
+#define VECTOR_LENGTH(v)  MAKINUM(LENGTH(v))
+
+#ifdef FLOATS
+#include <math.h>
+#endif
+#ifdef BIGDIG
+#define PRE_TRANSC_FUN(x) (INUMP(x) ? (double) INUM(x) : (REALP(x) ? (double) REALPART(x) : (double) big2dbl(x)))
+#else
+#define PRE_TRANSC_FUN(x) (INUMP(x) ?  (double) INUM(x) : (double) REALPART(x))
+#endif
+
+#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0))
+#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0))
+#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0))
+#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0))
+#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0))
+#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0))
+#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0))
+#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0))
+#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0))
+#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0))
+#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0))
+#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0))
+#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0))
+#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0))
+#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0))
+#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0))
+#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0))
+#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0))
+#define FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0))
+#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0))
+#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0))
+#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0))
+
+/* the following defs come from the #ifdef HOBBIT part of scm.h */
+
+#define SBOOL(x) ((x) ? BOOL_T : BOOL_F)
+
+#define BOOLEAN_P(x) ((x)==BOOL_T || (x)==BOOL_F)
+#define CHAR_P ICHRP
+#define SYMBOL_P(x) (ISYMP(x) || (!(IMP(x)) && SYMBOLP(x))) 
+#define VECTOR_P(x) (!(IMP(x)) && VECTORP(x)) 
+#define PAIR_P(x) (!(IMP(x)) && CONSP(x))     
+#define NUMBER_P INUMP
+#define INTEGER_P INUMP
+#define STRING_P(x) (!(IMP(x)) && STRINGP(x))
+#define NULL_P NULLP
+#define ZERO_P(x) ((x)==INUM0)
+#define POSITIVE_P(x) ((x) > INUM0)
+#define NEGATIVE_P(x) ((x) < INUM0)
+
+#define NOT(x) ((x)==BOOL_F ? BOOL_T : BOOL_F)
+#define SET_CAR(x,y) (CAR(x) = (SCM)(y))
+#define SET_CDR(x,y) (CDR(x) = (SCM)(y))
+#define VECTOR_SET(v,k,o) (VELTS(v)[((long)INUM(k))] = o)
+#define VECTOR_REF(v,k) (VELTS(v)[((long)INUM(k))])
+#define GLOBAL(x) (*(x))
+
+#define append2(lst1,lst2) (append(cons2(lst1,lst2,EOL)))
+#define procedure_pred_(x) (BOOL_T==procedurep(x))
+
+/* new for hobbit5 - scm5 */
+
+/*
+SCM intp(SCM);
+SCM eqv(SCM,SCM);
+*/
diff --git a/scmhob.scm b/scmhob.scm
new file mode 100644
index 0000000..bdef580
--- /dev/null
+++ b/scmhob.scm
@@ -0,0 +1,51 @@
+;====================================================================
+;
+;    scmhob.scm defines several procedures recognized
+;    by the hobbit compiler as primitives, but not defined in scm or slib.
+;      
+;    Use scmhob when running code (meant for compilation by
+;    hobbit) under interpreter. Never compile scmhob.scm!
+;      
+;    Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 Tanel Tammet
+;    tammet@cs.chalmers.se
+;
+;                        version 5x
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation; either version 1, or (at your option)
+; any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+; 
+;====================================================================
+
+; bitwise operations: logical shift left and logical shift right
+
+(define (logsleft x y) (ash x y))
+(define (logsright x y) (ash x (- 0 y)))
+
+; immediate-integer (30-bit signed int) versions of arithmetic primitives:
+
+(define %eqv? eqv?)
+(define %zero? zero?)
+(define %negative? negative?)
+(define %positive? positive?)
+(define %number? number?)
+(define %= =)
+(define %< <)
+(define %> >)
+(define %<= <=)
+(define %>= >=)
+(define %+ +)
+(define %- -)
+(define %* *)
+(define %/ /)
+
diff --git a/scmmain.c b/scmmain.c
index 3f920dd..ce2d000 100644
--- a/scmmain.c
+++ b/scmmain.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -42,9 +42,20 @@
 /* "scmmain.c" main() for SCM.
    Author: Aubrey Jaffer */
 
+/* added by Dai Inukai 2001-03-21*/
+#ifdef __FreeBSD__
+# include <floatingpoint.h>
+#endif
+
 #include "scm.h"
 #include "patchlvl.h"
 
+#ifdef __IBMC__
+# include <io.h>
+#endif
+#ifdef __OpenBSD__
+# include <unistd.h>
+#endif
 #ifndef GENERIC_NAME
 # define GENERIC_NAME "scm"
 #endif
@@ -86,17 +97,23 @@ int main(argc, argv)
   char *script_arg = 0;		/* location of SCSH style script file or 0. */
   char *implpath = 0, **nargv;
   int nargc, iverbose = 0, buf0stdin;
-  int freeall = 1;		/* Free storage when we're done. */
   SCM retval;
-
+/* added by Dai Inukai 2001-03-21 */
+#ifdef __FreeBSD__
+  fp_prec_t fpspec;
+#endif
 /*    {char ** argvv = argv; */
-/*    for (;*argvv;argvv++) {fputs(*argvv,stderr); fputs(" ",stderr);} */
-/*    fputs("\n",stderr);} */
+/*    for (;*argvv;argvv++) {fputs(*argvv, stderr); fputs(" ", stderr);} */
+/*    fputs("\n", stderr);} */
 
   if (0==argc) {argc = 1; argv = generic_name;} /* for macintosh */
 #ifndef LACK_SBRK
   init_sbrk();			/* Do this before malloc()s. */
 #endif
+/* added by Dai Inukai 2001-03-21 */
+#ifdef __FreeBSD__
+   fpspec = fpsetprec(FP_PE); /* IEEE 64 bit FP mantissa*/
+#endif
   execpath = 0;			/* even when dumped */
   if ((nargv = script_process_argv(argc, argv))) { /* SCSH style scripts */
     script_arg = argv[2];	/* Save for scm_find_execpath() call */
@@ -126,7 +143,7 @@ int main(argc, argv)
 #ifdef CAREFUL_INTS
 	    1
 #else
-	    freeall || (2 <= verbose)
+	    1 /* freeall || (2 <= verbose) */ /* Free storage when we're done. */
 #endif
 	    );
   if (2 <= iverbose) fputs(";EXIT\n", stderr);
@@ -134,6 +151,12 @@ int main(argc, argv)
   if (implpath) free(implpath);
   if (execpath) free(execpath);
   execpath = 0;
+/* added by Dai Inukai 2001-03-27 */
+#ifdef __FreeBSD__
+  fpspec = fpsetprec(fpspec); /* Set back to FP_PD which is 53 bit FP. */
+                              /* This may not be needed because the    */
+                              /* kernel is set to FP_PD by default.    */
+#endif
   return (int)INUM(retval);
 }
 
diff --git a/script.c b/script.c
index efeaf5b..5cbe10f 100644
--- a/script.c
+++ b/script.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -52,13 +52,13 @@
 #ifdef linux
 # include <unistd.h>     /* for X_OK define */
 #endif /* def linux */
-#ifdef __svr4__
+#ifdef __SVR4
 # include <unistd.h>     /* for X_OK define */
 #else
 # ifdef __sgi__
 #  include <unistd.h>     /* for X_OK define */
 # endif /* def __sgi__ */
-#endif /* def __svr4__ */
+#endif /* def __SVR4 */
 
 /* Concatentate str2 onto str1 at position n and return concatenated
    string if file exists; 0 otherwise. */
@@ -124,7 +124,7 @@ char *scm_sep_init_try(path, sep, initname)
 # define X_OK 1
 #endif /* ndef X_OK */
 
-#ifdef unix
+#ifdef HAVE_UNIX
 # include <stdio.h>
 
 char *script_find_executable(name)
@@ -156,7 +156,6 @@ char *script_find_executable(name)
 #endif /* unix */
 
 #ifdef MSDOS
-
 # define DEFAULT_PATH "C:\\DOS"
 # define PATH_DELIMITER ';'
 # define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \
@@ -170,6 +169,20 @@ char *dld_find_executable(file)
 }
 #endif /* def MSDOS */
 
+#ifdef __IBMC__
+# define PATH_DELIMITER ';'
+# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') \
+             || (fname[0] == '\\') \
+             || (fname[0] && (fname[1] == ':')))
+
+char *dld_find_executable(file)
+     const char *file;
+{
+  /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
+  return scm_cat_path(0L, file, 0L);
+}
+#endif /* def __IBMC__ */
+
 /* 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
@@ -227,7 +240,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep)
 	  path = scm_sep_init_try(path, sep, initname);
 	  if (path) return path;
 	}
-	if (!strcmp(peer,"src")) break;
+	if (!strcmp(peer, "src")) break;
       }
 
       if (generic_name) {
@@ -242,7 +255,7 @@ char *find_impl_file(exec_path, generic_name, initname, sep)
 	    path = scm_sep_init_try(path, sep, initname);
 	    if (path) return path;
 	  }
-	  if (!strcmp(peer,"src")) break;
+	  if (!strcmp(peer, "src")) break;
 	}}
 
       /* Look for initname in executable-name peer directory. */
@@ -377,7 +390,7 @@ char **script_process_argv(argc, argv)
   int nargc = argc, argi = 1, nargi = 1;
   char *narg, **nargv;
   if (!(argc > 2 && script_meta_arg_P(argv[1]))) return 0L;
-  if (!(nargv = (char **)malloc((1 + nargc) * sizeof(char*)))) return 0L;
+  if (!(nargv = (char **)malloc((1 + nargc) * sizeof(char *)))) return 0L;
   nargv[0] = argv[0];
   while (((argi+1) < argc) && (script_meta_arg_P(argv[argi]))) {
     FILE *f = fopen(argv[++argi], "r");
@@ -389,7 +402,7 @@ char **script_process_argv(argc, argv)
       case '\n': goto found_args;
       }
     found_args: while ((narg = script_read_arg(f)))
-      if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char*))))
+      if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char *))))
 	return 0L;
       else nargv[nargi++] = narg;
       fclose(f);
diff --git a/setjump.h b/setjump.h
index b794bca..dfacb84 100644
--- a/setjump.h
+++ b/setjump.h
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -125,7 +125,11 @@
 /* other.dynenv and other.parent get GCed just by being there.  */
 struct scm_other {SCM dynenv;
 		  SCM parent;
-                  SCM stkframe[2];
+#ifdef RECKLESS
+		  SCM stkframe[2];
+#else
+		  SCM stkframe[4];
+#endif
                   SCM estk;
 		  SCM *estk_ptr;
 		};
diff --git a/socket.c b/socket.c
index 68e0195..5c0aa7b 100644
--- a/socket.c
+++ b/socket.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -69,6 +69,9 @@
 # ifdef SVR4
 #  include <unistd.h>
 # endif
+# ifdef __OpenBSD__
+#  include <unistd.h>
+# endif
 #endif /* STDC_HEADERS */
 
 static char s_inetaddr[] = "inet:string->address";
@@ -313,9 +316,8 @@ SCM l_socket(fam, proto)
     close(sd);
     wta(MAKINUM(sd), (char *)NALLOC, s_port_type);
   }
-  CAR(port) = scm_port_entry(tc_socket, BUF0);
+  port = scm_port_entry(f, tc_socket, BUF0);
   SCM_PORTDATA(port) = fam;
-  SETSTREAM(port, f);
   i_setbuf0(port);
   ALLOW_INTS;
   if (AF_INET==tp) {
@@ -354,9 +356,8 @@ SCM l_socketpair(fam, proto)
     close(sv[1]);
     wta(MAKINUM(sv[1]), (char *)NALLOC, s_port_type);
   }
-  CAR(port[0]) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0));
-  CAR(port[1]) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0));
-  SETSTREAM(port[0], f[0]); SETSTREAM(port[1], f[1]);
+  port[0] = scm_port_entry(f[0], tc16_fport, mode_bits("r+0", (char *)0));
+  CAR(port[1]) = scm_port_entry(f[1], tc16_fport, mode_bits("r+0", (char *)0));
   i_setbuf0(port[0]); i_setbuf0(port[1]);
   ALLOW_INTS;
   return cons(port[0], port[1]);
@@ -387,6 +388,7 @@ static char s_connect[] = "socket:connect";
 SCM l_connect (sockpt, address, arg)
      SCM sockpt, address, arg;
 {
+  long flags;
   int sts;
   ASSERT(NIMP(sockpt) && SOCKP(sockpt), sockpt, ARG1, s_connect);
   switch SOCKTYP(sockpt) {
@@ -419,7 +421,9 @@ SCM l_connect (sockpt, address, arg)
     break;
   }
   if (sts) return BOOL_F;
-  CAR(sockpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0));
+  flags = tc16_fport | mode_bits("r+0", (char *)0);
+  SCM_PORTFLAGS(sockpt) = flags;
+  SCM_SETFLAGS(sockpt, flags);
   SCM_PORTDATA(sockpt) = cons(address, arg);
   return sockpt;
 }
@@ -464,13 +468,16 @@ static char s_listen[] = "socket:listen";
 SCM l_listen(port, backlog)
      SCM port, backlog;
 {
+  long flags;
   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;
   DEFER_INTS;
-  CAR(port) = scm_port_entry(tc16_fport, mode_bits("r0", (char *)0));
+  flags  = tc16_fport | mode_bits("r0", (char *)0);
+  SCM_PORTFLAGS(port) = flags;
+  SCM_SETFLAGS(port, flags);
   ALLOW_INTS;
   return port;
 }
@@ -500,8 +507,7 @@ SCM l_accept(sockpt)
     close(newsd);
     wta(MAKINUM(newsd), (char *)NALLOC, s_port_type);
   }
-  CAR(newpt) = scm_port_entry(tc16_fport, mode_bits("r+0", (char *)0));
-  SETSTREAM(newpt, newfd);
+  newpt = scm_port_entry(newfd, tc16_fport, mode_bits("r+0", (char *)0));
   i_setbuf0(newpt);
   ALLOW_INTS;
   return newpt;
diff --git a/subr.c b/subr.c
index e55bf17..e8b5176 100644
--- a/subr.c
+++ b/subr.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -476,14 +476,14 @@ SCM modulo(x, 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);
+    return divbigint(x, z, z < 0, (BIGSIGN(x) ? (z > 0) : (z < 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;
+    return (BIGSIGN(y) ? (INUM(x)>0) : (INUM(x)<0)) ? sum(x, y) : x;
   }
 #else
   ASSERT(INUMP(x), x, ARG1, s_modulo);
@@ -546,7 +546,8 @@ b3:
   if (!(1 & (int)t)) goto b3;
   if (t>0) u = t;
   else v = -t;
-  if ((t = u-v)) goto b3;
+  t = u-v;
+  if (t) goto b3;
   u = u*k;
 getout:
   if (!POSFIXABLE(u))
@@ -612,6 +613,7 @@ 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_big_ash P((SCM x, long cnt));
 
 SCM scm_copy_big_dec(b, sign)
      SCM b;
@@ -751,7 +753,7 @@ SCM scm_big_and(x, nx, xsgn, bigy, zsgn)
   }
   else if (xsgn) do {
     num += x[i];
-    if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
+    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);
@@ -800,6 +802,151 @@ SCM scm_big_test(x, nx, xsgn, bigy)
   return BOOL_F;
 }
 
+static SCM scm_copy_big_2scomp P((SCM x, sizet blen, int sign));
+static void scm_2scomp1 P((SCM b));
+static SCM scm_copy_big_2scomp(x, blen, sign)
+     SCM x;
+     sizet blen;
+     int sign;
+{
+  sizet nres = (blen + BITSPERDIG - 1)/BITSPERDIG;
+  SCM res;
+  BIGDIG *rds;
+  long num = 0;
+  sizet i;
+  if INUMP(x) {
+    long lx = INUM(x);
+    if (nres < (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG)
+      nres = (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG;
+    res = mkbig(nres, sign);
+    rds = BDIGITS(res);
+    if (lx < 0) {
+      lx = -lx;
+      for (i = 0; i < nres; i++) {
+	num -= BIGLO(lx);
+	lx = BIGDN(lx);
+	if (num < 0) {
+	  rds[i] = num + BIGRAD;
+	  num = -1;
+	}
+	else {
+	  rds[i] = num;
+	  num = 0;
+	}
+      }
+    }
+    else {
+      for (i = 0; i < nres; i++) {
+	rds[i] = BIGLO(lx);
+	lx = BIGDN(lx);
+      }
+    }
+  }
+  else {
+    BIGDIG *xds = BDIGITS(x);
+    sizet nx = NUMDIGS(x);
+    if (nres < nx)
+      nres = nx;
+    res = mkbig(nres, sign);
+    rds = BDIGITS(res);
+    if BIGSIGN(x) {
+      for (i = 0; i < nx; i++) {
+	num -= xds[i];
+	if (num < 0) {
+	  rds[i] = num + BIGRAD;
+	  num = -1;
+	}
+	else {
+	  rds[i] = num;
+	  num = 0;
+	}
+      }
+      for (; i < nres; i++)
+	rds[i] = BIGRAD - 1;
+    }
+    else {
+      for (i = 0; i < nx; i++)
+	rds[i] = xds[i];
+      for (; i < nres; i++)
+	rds[i] = 0;
+    }
+  }
+  return res;
+}
+static void scm_2scomp1(b)
+     SCM b;
+{
+  long num = 0;
+  sizet i, n = NUMDIGS(b);
+  BIGDIG *bds = BDIGITS(b);
+  for (i = 0; i < n; i++) {
+    num -= bds[i];
+    if (num < 0) {
+      bds[i] = num + BIGRAD;
+      num = -1;
+    }
+    else {
+      bds[i] = num;
+      num = 0;
+    }
+  }
+}
+
+SCM scm_big_ash(x, cnt)
+     SCM x;
+     long cnt;
+{
+  SCM res;
+  BIGDIG *resds;
+  unsigned long d;
+  int sign, ishf;
+  long i, fshf, blen, n;
+  if INUMP(x) {
+    blen = LONG_BIT;
+    sign = INUM(x) < 0 ? 0x0100 : 0;
+  }
+  else {
+    blen = NUMDIGS(x)*BITSPERDIG;
+    sign = BIGSIGN(x);
+  }
+  if (cnt < 0) {
+    if (blen <= -cnt) return sign ? MAKINUM(-1) : INUM0;
+    ishf = (-cnt) / BITSPERDIG;
+    fshf = (-cnt) % BITSPERDIG;
+    res = scm_copy_big_2scomp(x, blen, sign);
+    resds = BDIGITS(res);
+    n = NUMDIGS(res) - ishf - 1;
+    for (i = 0; i < n; i++) {
+      d = (resds[i + ishf]>>fshf) |
+	((resds[i + ishf + 1])<<(BITSPERDIG - fshf) & (BIGRAD - 1));
+      resds[i] = d;
+    }
+    d = (resds[i + ishf]>>fshf);
+    if (sign) d |= ((BIGRAD - 1)<<(BITSPERDIG - fshf) & (BIGRAD - 1));
+    resds[i] = d;
+    n = NUMDIGS(res);
+    d = sign ? BIGRAD - 1 : 0;
+    for (i++; i < n; i++)
+      resds[i] = d;
+  }
+  else {
+    ishf = cnt / BITSPERDIG;
+    fshf = cnt % BITSPERDIG;
+    res = scm_copy_big_2scomp(x, blen + cnt, sign);
+    resds = BDIGITS(res);
+    for (i = NUMDIGS(res) - 1; i > ishf; i--) {
+      d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1)) |
+	((resds[i - ishf - 1])>>(BITSPERDIG - fshf));
+      resds[i] = d;
+    }
+    d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1));
+    resds[i] = d;
+    for (i--; i >= 0; i--)
+      resds[i] = 0;
+  }
+  if (sign) scm_2scomp1(res);
+  return normbig(res);
+}
 #endif
 
 static char s_logand[] = "logand", s_lognot[] = "lognot",
@@ -996,7 +1143,7 @@ SCM scm_logbitp(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);
+    ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp);
     if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
     else if BIGSIGN(j1) {
       long num = -1;
@@ -1015,7 +1162,7 @@ SCM scm_logbitp(index, j1)
 		 (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F;
   }
 #else
-  ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp);
+  ASSERT(INUMP(j1), j1, ARG2, s_logbitp);
 #endif
   return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
 }
@@ -1025,13 +1172,29 @@ SCM scm_copybit(index, j1, bit)
 {
   ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit);
 #ifdef BIGDIG
-  if (NINUMP(j1) || (INUM(index) >= LONG_BIT - 3))
-    /* This function makes more bignums than it needs to. */
-    if NFALSEP(bit)
-      return scm_logior(j1, scm_ash(MAKINUM(1), index));
-    else
-      return scm_logand(j1, difference(MAKINUM(-1L),
-				       scm_ash(MAKINUM(1), index)));
+  {
+    SCM res;
+    BIGDIG *rds;
+    sizet i = INUM(index);
+    int sign;
+    if (!INUMP(j1)) {
+      ASSERT(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit);
+      sign = BIGSIGN(j1);
+    ovflow:
+      res = scm_copy_big_2scomp(j1, i + 1, sign);
+      rds = BDIGITS(res);
+      if (NFALSEP(bit))
+	rds[i / BITSPERDIG] |= 1 << (i % BITSPERDIG);
+      else
+	rds[i / BITSPERDIG] &= ~(1 << (i % BITSPERDIG));
+      if (sign) scm_2scomp1(res);
+      return normbig(res);
+    }
+    if (i >= LONG_BIT - 3) {
+      sign = INUM(j1) < 0 ? 0x0100 : 0;
+      goto ovflow;
+    }
+  }
 #else
   ASSERT(INUMP(j1), j1, ARG2, s_copybit);
   ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
@@ -1053,37 +1216,61 @@ SCM scm_ash(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);
+  cnt = INUM(cnt);
+  if (INUMP(n)) {
+    if (cnt < 0) return MAKINUM(SRS(res, -cnt));
+    if (cnt >= LONG_BIT) goto ovflow;
+    res = MAKINUM(res<<cnt);
+    if (INUM(res)>>cnt != INUM(n))
+      goto ovflow;
+    else
+      return res;
   }
-  else return product(n, scm_intexpt(MAKINUM(2), cnt));
+#ifdef BIGDIG
+  ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_ash);
+ ovflow:
+  if (0==cnt) return n;
+  return scm_big_ash(n, 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;
+ ovflow:
+  wta(n, INUMP(n) ? (char *)OVFLOW : (char *)ARG1, s_ash);
+  return UNSPECIFIED;	/* kill warning */
 #endif
 }
 
 SCM scm_bitfield(n, start, end)
      SCM n, start, end;
 {
+  int sign;
   ASSERT(INUMP(start), start, ARG2, s_bitfield);
   ASSERT(INUMP(end), end, ARG3, s_bitfield);
   start = INUM(start); end = INUM(end);
   ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
 #ifdef BIGDIG
-  if (NINUMP(n) || end >= LONG_BIT - 2)
-    return
-      scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)),
-			    MAKINUM(1L)),
-		 scm_ash(n, MAKINUM(-start)));
+  if (NINUMP(n)) {
+    BIGDIG *ds;
+    sizet i, nd;
+    ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_bitfield);
+    sign = BIGSIGN(n);
+  big:
+    if (sign) n = scm_copy_big_2scomp(n, (sizet)end, 0);
+    n = scm_big_ash(n, -start);
+    if (INUMP(n)) {
+      if (end - start >= LONG_BIT - 2) return n;
+      return MAKINUM(INUM(n) & ((1L<<(end - start)) - 1));
+    }
+    nd = NUMDIGS(n);
+    ds = BDIGITS(n);
+    i = (end - start) / BITSPERDIG;
+    if (i >= nd) return n;
+    ds[i] &= ((1 << ((end - start) % BITSPERDIG)) - 1);
+    for (++i; i < nd; i++) ds[i] = 0;
+    return normbig(n);
+  }
+  if (end >= LONG_BIT - 2) {
+    sign = INUM(n) < 0;
+    goto big;
+  }
 #else
   ASSERT(INUMP(n), n, ARG1, s_bitfield);
   ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
@@ -1126,7 +1313,7 @@ SCM scm_copybitfield(to, start, rest)
   ASSERT(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield);
 #ifdef BIGDIG
   if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) {
-    SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L));
+    SCM mask = difference(scm_ash(MAKINUM(1L), MAKINUM(len)), MAKINUM(1L));
     mask = scm_ash(mask, start);
     return scm_logior(scm_logand(mask, scm_ash(from, start)),
 		      scm_logand(scm_lognot(mask), to));
@@ -1568,7 +1755,7 @@ SCM make_vector(k, fill)
   if UNBNDP(fill) fill = UNSPECIFIED;
   i = INUM(k);
   DEFER_INTS;
-  v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L,
+  v = must_malloc_cell(i ? i*sizeof(SCM) : 1L,
 		       MAKE_LENGTH(i, tc7_vector), s_vector);
   velts = VELTS(v);
   while(--i >= 0) (velts)[i] = fill;
@@ -1585,7 +1772,7 @@ SCM mkbig(nlen, sign)
   if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (char *)NALLOC, s_bignum);
   DEFER_INTS;
   v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG),
-		       MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos),
+		       MAKE_NUMDIGS(nlen, sign ? tc16_bigneg : tc16_bigpos),
 		       s_bignum);
   ALLOW_INTS;
   return v;
@@ -1600,7 +1787,7 @@ SCM big2inum(b, l)
   if (TYP16(b)==tc16_bigpos) {
     if POSFIXABLE(num) return MAKINUM(num);
   }
-  else if UNEGFIXABLE(num) return MAKINUM(-num);
+  else if UNEGFIXABLE(num) return MAKINUM(-(long)num);
   return b;
 }
 char s_adjbig[] = "adjbig";
@@ -1809,7 +1996,7 @@ SCM divbigint(x, z, sgn, mode)
     sizet nd = NUMDIGS(x);
     while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z;
     if (mode && t2) t2 = z - t2;
-    return MAKINUM(sgn ? -t2 : t2);
+    return MAKINUM(sgn ? -(long)t2 : t2);
   }
   {
 # ifndef DIGSTOOBIG
diff --git a/syntest1.scm b/syntest1.scm
new file mode 100644
index 0000000..f10be86
--- /dev/null
+++ b/syntest1.scm
@@ -0,0 +1,166 @@
+;Most of the tests themselves are taken from William Clinger's reference 
+;implementation of syntax-rules, `macros.will' in the Scheme repository
+;at ftp.cs.indiana.edu
+
+;Copyright 1992 William Clinger
+
+;Permission to copy this software, in whole or in part, to use this
+;software for any lawful purpose, and to redistribute this software
+;is granted subject to the restriction that all copies made of this
+;software must include this copyright notice in full.
+
+;I also request that you send me a copy of any improvements that you
+;make to this software so that they may be incorporated within it to
+;the benefit of the Scheme community.
+
+
+(require 'macro)
+
+(define synerrs '())
+
+(define-syntax test
+  (syntax-rules ()
+		((test ?exp ?ans)
+		 (begin
+		   (display '?exp)
+		   (display " ==> ")
+		   (let* ((exp (copy-tree '?exp))
+			  (x ?exp)
+			  #+f(x (eval (macro:expand '?exp)))
+			  )
+		     (display x)
+		     (newline)
+		     (or (equal? x ?ans)
+			 (begin
+			   (set! synerrs
+				 (cons (list x ?ans '?exp) synerrs))
+			   (display "ERROR: expected ")
+			   (display ?ans)
+			   (newline))))))
+		((test ?exp0 ?exp1 ?exp2 ...)
+		 (begin (display '?exp0)
+			(newline)
+			?exp0 (test ?exp1 ?exp2 ...)))))
+
+(test (let ((x 'outer))
+	(let-syntax ((m (syntax-rules () ((m) x))))
+	  (let ((x 'inner))
+	    (m))))
+      'outer)
+
+(test (let-syntax ((when (syntax-rules
+			  ()
+			  ((when ?test ?stmt1 ?stmt2 ...)
+			   (if ?test (begin ?stmt1 ?stmt2 ...))))))
+	(let ((if #t))
+	  (when if (set! if 'now))
+	  if))
+      'now)
+
+(test (letrec-syntax
+	  ((or (syntax-rules
+		()
+		((or) #f)
+		((or ?e) ?e)
+		((or ?e1 ?e2 ...)
+		 (let ((temp ?e1))
+		   (if temp temp (or ?e2 ...)))))))
+	(let ((x #f)
+	      (y 7)
+	      (temp 8)
+	      (let odd?)
+	      (if even?))
+	  (or x
+	      (let temp)
+	      (if y)
+	      y)))
+      7)
+
+(test (let ((=> #f))
+	(cond (#t => 'ok)))
+      'ok)
+
+; This syntax of set*! matches that of an example in the R4RS.
+; That example was put forth as an example of a hygienic macro
+; that supposedly couldn't be written using syntax-rules.  Hah!
+
+(test (define-syntax set*!
+	(syntax-rules
+	 ()
+	 ((set*! (?var ?val) ...)
+	  (set*!-help (?val ...) () (?var ?val) ...))))
+      (define-syntax set*!-help
+	(syntax-rules
+	 ()
+	 ((set*!-help () (?temp ...) (?var ?val) ...)
+	  (let ((?temp ?val) ...)
+	    (set! ?var ?temp) ...))
+	 ((set*!-help (?var1 ?var2 ...) ?temps ?assignments ...)
+	  (set*!-help (?var2 ...) (temp . ?temps) ?assignments ...))))
+      (let ((x 3)
+	    (y 4)
+	    (z 5))
+	(set*! (x (+ x y z))
+	       (y (- x y z))
+	       (z (* x y z)))
+	(list x y z))
+
+      '(12 -6 60))
+
+(test (let ((else #f))
+	(cond (#f 3)
+	      (else 4)
+	      (#t 5)))
+      5)
+
+(test (define-syntax push
+	(syntax-rules ()
+		      ((push item place)
+		       (set! place (cons item place)))))
+      (let* ((cons (lambda (name)
+		     (case name
+		       ((phil)  '("three-card monte"))
+		       ((dick)  '("secret plan to end the war"
+				  "agnew"
+				  "not a crook"))
+		       ((jimmy) '("why not the best"))
+		       ((ron)   '("abolish the draft"
+				  "balance the budget"))
+		       (else    '()))))
+	     (scams (cons 'phil)))
+	(push (car (cons 'jimmy)) scams)
+	(push (cadr (cons 'ron)) scams)
+	scams)
+      '("balance the budget" "why not the best" "three-card monte"))
+
+(test (define-syntax replic
+	(syntax-rules ()
+	  ((_ (?x ...) (?y ...))
+	   (let ((?x (list ?y ...)) ...)
+	     (list ?x ...)))))
+      (replic (x y z) (1 2))
+      '((1 2) (1 2) (1 2)))
+
+;; The behavior of this one is one is not specified by R5RS, below
+;; is what SCM does.
+;(test (define-syntax spread
+;	(syntax-rules ()
+;	  ((_ ?x (?y ...))
+;	   '(((?x ?y) ...)))))
+;      (spread x (1 2 3))
+;      '(((x 1) (x 2) (x 3))))
+
+(cond
+ ((null? synerrs)
+  (newline)
+  (display "Passed all tests\n")
+  (display "Load \"syntest2\" to rewrite derived expressions and test\n"))
+ (else
+  (newline)
+  (display "FAILED, errors were:")
+  (newline)
+  (display "(got expected call)")
+  (newline)
+  (for-each (lambda (l) (write l) (newline)) synerrs)
+  (newline)))
+
diff --git a/syntest2.scm b/syntest2.scm
new file mode 100644
index 0000000..68633cf
--- /dev/null
+++ b/syntest2.scm
@@ -0,0 +1,186 @@
+;; Copyright (C) 2000, 2001, 2002 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, 59 Temple Place, Suite 330, Boston, MA 02111, 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.
+
+(require 'macro)
+
+;; Redefine some derived special forms.
+
+(define-syntax let
+  (syntax-rules ()
+    ((let ((?name ?val) ...) . ?body)
+     ((lambda (?name ...) . ?body) ?val ...))
+    ((let ?proc ((?name ?val) ...) . ?body)
+     (let ((?proc #f)
+	   (?name ?val) ...)
+       (set! ?proc (lambda (?name ...) . ?body))
+       (?proc ?name ...)))))
+
+(define-syntax let*
+  (syntax-rules ()
+    ((let* () . ?body)
+     ((lambda () . ?body)))
+    ((let* ((?name ?val)) . ?body)
+     ((lambda (?name) . ?body) ?val))
+    ((let* ((?name ?val) ?binding ...) . ?body)
+     (let* ((?name ?val))
+       (let* (?binding ...) . ?body)))))
+
+(define-syntax letrec
+  (syntax-rules ()
+    ((letrec ((?name ?val) ...) . ?body)
+     (let ((?name #f) ...)
+       (set! ?name ?val) ...
+       (let () . ?body)))))
+
+(define-syntax and
+  (syntax-rules ()
+    ((and) #t)
+    ((and ?exp)
+     (let ((x ?exp))
+       (if x x #f)))
+    ((and ?exp . ?rest)
+     (let ((x ?exp))
+       (if x (and . ?rest) #f)))))
+
+(define-syntax or
+  (syntax-rules ()
+    ((or) #f)
+    ((or ?exp)
+     (let ((x ?exp))
+       (if x x #f)))
+    ((or ?exp . ?rest)
+     (let ((x ?exp))
+       (if x x (or . ?rest))))))
+
+(define (force promise)
+  (promise))
+
+(define (make-promise proc)
+  (let ((result #f))
+    (lambda ()
+      (if result (car result)
+	  (let ((x (proc)))
+	    (if result (car result)
+		(begin (set! result (list x))
+		       x)))))))
+
+(define-syntax delay
+  (syntax-rules ()
+    ((delay ?expr)
+     (make-promise (lambda () ?expr)))))
+
+(define-syntax do
+  (syntax-rules ()
+    ((do ((?name ?init . ?step) ...)
+	 (?test . ?result)
+       ?body ...)
+     (let-syntax ((do-step (syntax-rules ()
+			     ((do-step ?n) ?n)
+			     ((do-step ?n ?s) ?s)))
+		  (do-result (syntax-rules ()
+			       ((do-result) (if #f #f))
+			       ((do-result . ?r) (begin . ?r)))))
+       (let loop ((?name ?init) ...)
+	 (if ?test
+	     (do-result . ?result)
+	     (begin ?body ...
+		    (loop (do-step ?name . ?step) ...))))))))
+
+(define-syntax case
+  (syntax-rules (else)
+    ((case ?x (else . ?conseq))
+     (begin . ?conseq))
+    ((case ?x (?lst . ?conseq))
+     (if (memv ?x '?lst) (begin . ?conseq)))
+    ((case ?x (?lst . ?conseq) . ?rest)
+     (if (memv ?x '?lst)
+	 (begin . ?conseq)
+	 (case ?x . ?rest)))))
+
+(define-syntax cond
+  (syntax-rules (else =>)
+    ((cond ?clause0 . ?clauses)
+     (letrec-syntax 
+	 ((cond-aux
+	   (syntax-rules (else =>)
+	     ((cond-aux) (if #f #f))
+	     ((cond-aux (else . ?conseq))
+	      (begin . ?conseq))
+	     ((cond-aux (?test => ?proc) . ?rest)
+	      (let ((val ?test))
+		(if val (?proc val) (cond-aux . ?rest))))
+	     ((cond-aux (?test) . ?rest)
+	      (or ?test (cond-aux . ?rest)))
+	     ((cond-aux (?test . ?conseq) . ?rest)
+	      (if ?test (begin . ?conseq) (cond-aux . ?rest))))))
+       (cond-aux ?clause0 . ?clauses)))))
+
+;; This may fail if you redefine CONS, LIST, APPEND, or LIST->VECTOR
+;; It uses the (... ...) escape.
+;; All forms are evaluated inside a LETREC-SYNTAX body (is this a problem?).
+
+(define-syntax quasiquote
+  (syntax-rules ()
+    ((_ ?template)
+     (letrec-syntax
+	 ((qq
+	   (syntax-rules (unquote unquote-splicing quasiquote)
+	     ((_ (unquote ?form) ())
+	      ?form)
+	     ((_ (unquote ?form) (?depth))
+	      (list 'unquote (qq ?form ?depth)))
+	     ((_ (quasiquote ?form) ?depth)
+	      (list 'quasiquote (qq ?form (?depth))))
+	     ((_ ((unquote-splicing ?form) . ?rest) ())
+	      (append ?form (qq ?rest ())))
+	     ((_ ((unquote-splicing ?form) . ?rest) (?depth))
+	      (append (list 'unquote-splicing (qq ?form ?depth))
+		      (qq ?rest (?depth))))
+	     ((_ (?car . ?cdr) ?depth)
+	      (cons (qq ?car ?depth) (qq ?cdr ?depth)))
+	     ((_ #(?elt (... ...)) ?depth)
+	      (list->vector (qq (?elt (... ...)) ?depth)))
+	     ((_ ?atom ?depth)
+	      '?atom))))
+       (qq ?template ())))))
+
+;;(load "r4rstest.scm")
+
+
diff --git a/sys.c b/sys.c
index b63cb5e..3a8906f 100644
--- a/sys.c
+++ b/sys.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 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
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -48,6 +48,7 @@
 void	igc P((char *what, STACKITEM *stackbase));
 void	lfflush P((SCM port));		/* internal SCM call */
 SCM	*loc_open_file;		/* for open-file callback */
+SCM	*loc_try_create_file;
 
 /* ttyname() etc. should be defined in <unistd.h>.  But unistd.h is
    missing on many systems. */
@@ -57,7 +58,7 @@ SCM	*loc_open_file;		/* for open-file callback */
 	char *tmpnam P((char *s));
 	sizet fwrite ();
 # ifdef sun
-#  ifndef __svr4__
+#  ifndef __SVR4
         int fputs P((char *s, FILE* stream));
         int fputc P((char c, FILE* stream));
         int fflush P((FILE* stream));
@@ -72,15 +73,20 @@ SCM	*loc_open_file;		/* for open-file callback */
 # ifdef linux
 #  include <unistd.h>
 # endif
+# ifdef __OpenBSD__
+#  include <unistd.h>
+# endif
 #endif
 
 static void gc_sweep P((int contin_bad));
 
 char	s_nogrow[] = "could not grow", s_heap[] = "heap",
-	s_hplims[] = "hplims";
+  s_hplims[] = "hplims", s_try_create_file[] = "try-create-file";
+
 static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
 static char	s_input_portp[] = "input-port?",
 		s_output_portp[] = "output-port?";
+static char	s_port_closedp[] = "port-closed?";
 static char	s_try_open_file[] = "try-open-file";
 #define	s_open_file (&s_try_open_file[4])
 char	s_close_port[] = "close-port";
@@ -102,7 +108,9 @@ char	s_close_port[] = "close-port";
 #     else
 #      ifndef macintosh
 #       ifndef ARM_ULIB
-#        include <sys/ioctl.h>
+#        ifndef PLAN9
+#         include <sys/ioctl.h>
+#        endif
 #       endif
 #      endif
 #     endif
@@ -129,7 +137,10 @@ SCM i_setbuf0(port)		/* should be called with DEFER_INTS active */
 
 /* The CRDY bit is overloaded to indicate that additional processing
    is needed when reading or writing, such as updating line and column
-   numbers. */
+   numbers.  Returns 0 if cmodes is non-null and modes string is not
+   valid. */
+/* If nonnull, the CMODES argument receives a copy of all chars in MODES
+   which are allowed by ANSI C. */
 long mode_bits(modes, cmodes)
      char *modes, *cmodes;
 {
@@ -143,10 +154,15 @@ long mode_bits(modes, cmodes)
     case 'b': bits |= BINARY; goto outc;
     case '0': bits |= BUF0; break;
     case '?': bits |= (TRACKED | CRDY); break;
+    case 'x': bits |= EXCLUSIVE; break;
     outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
     }
-  if (cmodes) cmodes[iout] = 0;
-  return bits;
+  if (!cmodes) return bits;
+  cmodes[iout] = 0;
+  switch (cmodes[0]) {
+  default: return 0;
+  case 'r': case 'w': case 'a': return bits;
+  }
 }
 
 SCM try_open_file(filename, modes)
@@ -155,18 +171,22 @@ SCM try_open_file(filename, modes)
   register SCM port;
   FILE *f;
   char cmodes[4];
-  long flags = mode_bits(CHARS(modes), cmodes);
+  long flags;
   ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file);
-  NEWCELL(port);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
+  flags = mode_bits(CHARS(modes), cmodes);
+  ASSERT(flags, modes, ARG2, s_open_file);
+  if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) {
+    port = apply(*loc_try_create_file, filename, cons(modes, listofnull));
+    if (UNSPECIFIED != port) return port;
+  }
   DEFER_INTS;
-  SCM_OPENCALL(f = fopen(CHARS(filename), cmodes));
+  SCM_OPENCALL((f = fopen(CHARS(filename), cmodes)));
   if (!f) {
     ALLOW_INTS;
     return BOOL_F;
   }
-  SETSTREAM(port, f);
-  CAR(port) = scm_port_entry(tc16_fport, flags);
+  port = scm_port_entry(f, tc16_fport, flags);
   if (BUF0 & flags) i_setbuf0(port);
   ALLOW_INTS;
   SCM_PORTDATA(port) = filename;
@@ -182,6 +202,7 @@ SCM open_file(filename, modes)
 	       cons(modes, listofnull));
 }
 
+long tc16_clport;
 SCM close_port(port)
      SCM port;
 {
@@ -194,6 +215,10 @@ SCM close_port(port)
 	  SYSCALL((ptobs[i].fclose)(STREAM(port)););
 	}
 	CAR(port) &= ~OPN;
+	SCM_PORTFLAGS(port) &= ~OPN;
+	/* Bash the old ptobnum with the closed port ptobnum.
+	   This allows catching some errors cheaply. */
+	SCM_SET_PTOBNUM(port, tc16_clport);
 	ALLOW_INTS;
 	return UNSPECIFIED;
 }
@@ -209,6 +234,24 @@ SCM output_portp(x)
 	if IMP(x) return BOOL_F;
 	return OUTPORTP(x) ? BOOL_T : BOOL_F;
 }
+SCM port_closedp(port)
+     SCM port;
+{
+  ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
+  if CLOSEDP(port) return BOOL_T;
+  return BOOL_F;
+}
+SCM scm_port_type(port)
+     SCM port;
+{
+  int i;
+  if (NIMP(port) && PORTP(port)) {
+    i = PTOBNUM(port);
+    if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED));
+    return BOOL_T;
+  }
+  return BOOL_F;
+}
 
 #if (__TURBOC__==1)
 # undef L_tmpnam		/* Not supported in TURBOC V1.0 */
@@ -307,16 +350,25 @@ void prinport(exp, port, type)
 #  ifndef _DCC
 #   ifndef AMIGA
 #    ifndef macintosh
+#     ifndef PLAN9
   if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp))))
     lputs(ttyname(fileno(STREAM(exp))), port);
   else
+#     endif
 #    endif
 #   endif
 #  endif
 # endif
 #endif
-    if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port);
-    else intprint(CDR(exp), -16, port);
+    {
+      SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED;
+      if (NIMP(s) && STRINGP(s))
+	iprin1(s, port, 1);
+      else if (OPFPORTP(exp))
+	intprint((long)fileno(STREAM(exp)), 10, port);
+      else
+	intprint(CDR(exp), -16, port);
+    }
   lputc('>', port);
 }
 
@@ -357,6 +409,24 @@ static int stgetc(p)
   CAR(p) = MAKINUM(ind + 1);
   return UCHARS(CDR(p))[ind];
 }
+static int stclose(p)
+     SCM p;
+{
+  SETCDR(p, nullstr);
+  return 0;
+}
+static int stungetc(c, p)
+     int c;
+     SCM p;
+{
+  sizet ind;
+  p = CDR(p);
+  ind = INUM(CAR(p));
+  if (ind == 0) return EOF;
+  CAR(p) = MAKINUM(--ind);
+  ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
+  return c;
+}
 int noop0(stream)
      FILE *stream;
 {
@@ -375,7 +445,8 @@ SCM mkstrport(pos, str, modes, caller)
   NEWCELL(z);
   DEFER_INTS;
   SETCHARS(z, str);
-  CAR(z) = scm_port_entry(tc16_strport, modes);
+  CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */
+  /*  z = scm_port_entry((FILE *)str, tc16_strport, modes); */
   ALLOW_INTS;
   return z;
 }
@@ -432,7 +503,7 @@ static ptobfuns fptob = {
 ptobfuns pipob = {
   0,
   mark0,
-  0,				/* replaced by pclose in init_ioext() */
+  0,				/* replaced by pclose in init_posix() */
   0,
   0,
   fputc,
@@ -456,8 +527,8 @@ static ptobfuns stptob = {
   stwrite,
   noop0,
   stgetc,
-  0};				/* stungetc */
-
+  stclose,
+  stungetc};
 
 				/* Soft ports */
 
@@ -523,6 +594,7 @@ SCM mksfpt(pv, modes)
      SCM pv, modes;
 {
   SCM z;
+  long flags;
   static long arities[] = {1, 1, 0, 0, 0};
 #ifndef RECKLESS
   int i;
@@ -534,11 +606,11 @@ SCM mksfpt(pv, modes)
 	   badarg);
   }
 #endif
-  ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
-  NEWCELL(z);
+  ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
+  flags = mode_bits(CHARS(modes), (char *)0);
+  ASSERT(flags, modes, ARG2, s_mksfpt);
   DEFER_INTS;
-  CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0));
-  SETSTREAM(z, pv);
+  z = scm_port_entry((FILE *)pv, tc16_sfport, flags);
   ALLOW_INTS;
   return z;
 }
@@ -556,6 +628,42 @@ static ptobfuns sfptob = {
   sfgetc,
   sfclose};
 
+		/* Closed ports, just return an error code and let
+		   the caller complain. */
+static int clputc(c, p)
+     int c; FILE *p;
+{
+  return EOF;
+}
+static sizet clwrite(str, siz, num, p)
+     sizet siz, num;
+     char *str; FILE *p;
+{
+  return 0;
+}
+static int clputs(s, p)
+     char *s; FILE *p;
+{
+  return EOF;
+}
+static int clgetc(p)
+     FILE *p;
+{
+  return EOF;
+}
+static ptobfuns clptob = {
+  s_port_type,
+  mark0,
+  noop0,
+  0,
+  0,
+  clputc,
+  clputs,
+  clwrite,
+  clgetc,
+  clgetc,
+  0};
+
 /* The following ptob is for printing system messages in an interrupt-safe
    way.  Writing to sys_errp while interrupts are disabled will never enable
    interrupts, do any actual i/o, or any allocation.  Messages will be
@@ -583,7 +691,7 @@ static sizet syswrite(str, siz, num, p)
     if NIMP(cur_outp) lflush(cur_outp);
     if (errbuf_end > 0) {
       if (errbuf_end > SYS_ERRP_SIZE) {
-	scm_warn("output buffer", " overflowed");
+	scm_warn("output buffer", " overflowed", UNDEFINED);
 	intprint((long)errbuf_end, 10, cur_errp);
 	lputs(" chars needed\n", cur_errp);
 	errbuf_end = errbuf_end % SYS_ERRP_SIZE;
@@ -644,16 +752,12 @@ SCM mksafeport(maxlen, port)
 {
   SCM z;
   if UNBNDP(port) port = cur_errp;
-  else {
-    ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
-  }
-  DEFER_INTS;
+  ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
   z = must_malloc_cell(sizeof(safeport)+0L,
 		       tc16_safeport | OPN | WRTNG,
 		       s_msp);
   ((safeport *)STREAM(z))->ccnt = maxlen;
   ((safeport *)STREAM(z))->port = port;
-  ALLOW_INTS;
   return z;
 }
 int reset_safeport(sfp, maxlen, port)
@@ -685,7 +789,7 @@ static sizet safewrite(str, siz, num, p)
     lputs(" ...", p->port);
     longjmp(p->jmpbuf, !0);	/* The usual C longjmp, not SCM's longjump */
   }
-  return siz;
+  return num;
 }
 static int safeputs(s, p)
      char *s; safeport *p;
@@ -787,33 +891,35 @@ extern sizet num_protects;	/* sys_protects now in scl.c */
 void init_types()
 {
   sizet j = num_protects;
-  /* Because not all protects may get initialized */
-  while(j) sys_protects[--j] = BOOL_F;
+  while(j) sys_protects[--j] = UNDEFINED;
 
   /* We need to set up tmp_errp before any errors may be
-     thrown, the port_table index will be zero, usable
+     thrown, the port_table index will be zero, usable by
      all ports that don't care about their table entries. */
   tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
-  CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG);
+  CAR(tmp_errp) = tc16_fport | OPN | WRTNG;
+  /*  CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */
   SETSTREAM(tmp_errp, stderr);
   cur_errp = def_errp = sys_safep = tmp_errp;
 
-  scm_init_gra(&subr_table_gra, sizeof(subr_info), 200, 0, "subr table");
-  scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 4, 255, "ptobs");
+  /* subrs_gra is trimmed to actual used by scm_init_extensions() */
+  scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs");
+  scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs");
   /* 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);
+  tc16_clport = newptob(&clptob);
   tc16_sysport = newptob(&sysptob);
   tc16_safeport = newptob(&safeptob);
-  scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs");
+  scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs");
   /* These newsmob calls must be done in this order */
   newsmob(&freecell);
   newsmob(&flob);
   newsmob(&bigob);
   newsmob(&bigob);
-  scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final);
+  scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final);
 }
 
 #ifdef TEST_FINAL
@@ -828,6 +934,24 @@ void add_final(final)
   scm_grow_gra(&finals_gra, (char *)&final);
 }
 
+static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL;
+static char s_add_finalizer[] = "add-finalizer";
+SCM scm_add_finalizer(value, finalizer)
+     SCM value, finalizer;
+{
+  SCM z;
+  ASSERT(NIMP(value), value, ARG1, s_add_finalizer);
+#ifndef RECKLESS
+  scm_arity_check(finalizer, 0L, s_add_finalizer);
+#endif
+  z = acons(value, finalizer, EOL);
+  DEFER_INTS;
+  CDR(z) = gc_finalizers;
+  gc_finalizers = z;
+  ALLOW_INTS;
+  return UNSPECIFIED;
+}
+
 static char s_estk[] = "environment stack";
 static cell ecache_v[ECACHE_SIZE];
 SCM scm_egc_roots[ECACHE_SIZE/20];
@@ -877,7 +1001,7 @@ void scm_estk_reset(size)
   if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1;
   scm_estk = make_stk_seg(size, UNDEFINED);
   scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]);
-  scm_estk_size = size;
+  scm_estk_size = size + 0L;
 }
 void scm_estk_grow()
 {
@@ -891,7 +1015,7 @@ void scm_estk_grow()
   sizet i, j;
   newv = VELTS(estk);
   oldv = VELTS(scm_estk);
-  j = scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN - overlap;
+  j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap;
   SCM_ESTK_PARENT(estk) = scm_estk;
   SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T;
   SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN);
@@ -901,19 +1025,18 @@ void scm_estk_grow()
   }
   scm_estk = estk;
   scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
-  scm_estk_size += size;
+  scm_estk_size += size + 0L;
   /*  growth_mon(s_estk, scm_estk_size, "locations", !0); */
 }
 void scm_estk_shrink()
 {
-  SCM parent, *v;
+  SCM parent;
   sizet i;
   parent = SCM_ESTK_PARENT(scm_estk);
   i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
-  v = VELTS(scm_estk);
   if IMP(parent) wta(UNDEFINED, "underflow", s_estk);
   if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk))
-    parent = make_stk_seg(LENGTH(parent), parent);
+    parent = make_stk_seg((sizet)LENGTH(parent), parent);
   SCM_ESTK_PARENT(scm_estk) = estk_pool;
   estk_pool = scm_estk;
   scm_estk_size -= LENGTH(scm_estk);
@@ -961,27 +1084,32 @@ void scm_env_cons2(w, x, y)
    scm_ecache_index = i;
 }
 
-/* scm_env_tmp = cons(x, scm_env_tmp) */
-void scm_env_cons_tmp(x)
-     SCM x;
+void scm_env_cons3(v, w, x, y)
+     SCM v, w, x, y;
 {
-   register SCM z;
+   SCM z1, z2;
    register int i;
    DEFER_INTS_EGC;
    i = scm_ecache_index;
-   if (1>i) {
+   if (3>i) {
      scm_egc();
      i = scm_ecache_index;
    }
-   z = PTR2SCM(&(scm_ecache[--i]));
-   CAR(z) = x;
-   CDR(z) = scm_env_tmp;
-   scm_env_tmp = z;
+   z1 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z1) = x;
+   CDR(z1) = y;
+   z2 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z2) = w;
+   CDR(z2) = z1;
+   z1 = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z1) = v;
+   CDR(z1) = z2;
+   scm_env_tmp = z1;
    scm_ecache_index = i;
 }
 
 void scm_env_v2lst(argc, argv)
-     int argc;
+     long argc;
      SCM *argv;
 {
    SCM z1, z2;
@@ -1004,7 +1132,23 @@ void scm_env_v2lst(argc, argv)
 }
 
 /* scm_env = acons(names, scm_env_tmp, scm_env) */
-void scm_extend_env(names)
+void scm_extend_env()
+{
+   SCM z;
+   register int i;
+   DEFER_INTS_EGC;
+   i = scm_ecache_index;
+   if (1>i) {
+     scm_egc();
+     i = scm_ecache_index;
+   }
+   z = PTR2SCM(&(scm_ecache[--i]));
+   CAR(z) = scm_env_tmp;
+   CDR(z) = scm_env;
+   scm_env = z;
+   scm_ecache_index = i;
+}
+void old_scm_extend_env(names)
      SCM names;
 {
    SCM z1, z2;
@@ -1028,15 +1172,17 @@ char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
 char s_recursive[] = "recursive";
 #define s_gc (s_cache_gc+6)
 static iproc subr0s[] = {
-  /*	{s_gc, gc}, */
 	{"tmpnam", ltmpnam},
+	{"open-ports", scm_open_ports},
 	{0, 0}};
 
 static iproc subr1s[] = {
 	{s_input_portp, input_portp},
 	{s_output_portp, output_portp},
+	{s_port_closedp, port_closedp},
 	{s_close_port, close_port},
 	{"eof-object?", eof_objectp},
+	{"port-type", scm_port_type},
 	{s_cwos, cwos},
 	{"object-hash", obhash},
 	{s_obunhash, obunhash},
@@ -1047,6 +1193,7 @@ static iproc subr2s[] = {
 	{s_try_open_file, try_open_file},
 	{s_cwis, cwis},
 	{s_mksfpt, mksfpt},
+	{s_add_finalizer, scm_add_finalizer},
 	{0, 0}};
 
 SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
@@ -1060,6 +1207,7 @@ void init_io()
   loc_open_file =
     &CDR(sysintern(s_open_file,
 		   CDR(sysintern(s_try_open_file, UNDEFINED))));
+  loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED));
 #ifndef CHEAP_CONTINUATIONS
   add_feature("full-continuation");
 #endif
@@ -1079,6 +1227,7 @@ long heap_cells = 0;
 CELLPTR *hplims, heap_org;
 VOLATILE SCM freelist = EOL;
 long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
+int gc_hook_pending = 0, gc_hook_active = 0;
 
 /* Ints should be deferred when calling igc_for_alloc. */
 static char *igc_for_alloc(where, olen, size, what)
@@ -1090,17 +1239,16 @@ static char *igc_for_alloc(where, olen, size, what)
   char *ptr;
   long nm;
 			/* Check to see that heap is initialized */
-  ASSERT(heap_cells>0, MAKINUM(size), NALLOC, what);
+  ASSERT(heap_cells > 0, MAKINUM(size), NALLOC, what);
+/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */
   igc(what, CONT(rootcont)->stkbse);
   nm = mallocated + size - olen;
   if (nm > mltrigger) {
     if (nm > mtrigger) grew_lim(nm + nm/2);
     else grew_lim(mtrigger + mtrigger/2);
   }
-  if (where)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    SYSCALL(ptr = (char *)malloc(size););
+  if (where) SYSCALL(ptr = (char *)realloc(where, size););
+  else SYSCALL(ptr = (char *)malloc(size););
   ASSERT(ptr, MAKINUM(size), NALLOC, what);
   if (nm > mltrigger) {
     if (nm > mtrigger) mtrigger = nm + nm/2;
@@ -1121,14 +1269,11 @@ char *must_malloc(len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)malloc(size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(0L, 0L, size, what);
-  else
-    mallocated = nm;
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
+  else mallocated = nm;
+/* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */
   return ptr;
 }
 SCM must_malloc_cell(len, c, what)
@@ -1145,14 +1290,11 @@ SCM must_malloc_cell(len, c, what)
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
   NEWCELL(z);
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)malloc(size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(0L, 0L, size, what);
-  else
-    mallocated = nm;
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
+  else mallocated = nm;
+/* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */
   SETCHARS(z, ptr);
   CAR(z) = c;
   return z;
@@ -1169,14 +1311,13 @@ char *must_realloc(where, olen, len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(where, olen, size, what);
-  else
-    mallocated = nm;
+  ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout);
+   printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  else mallocated = nm;
   return ptr;
 }
 void must_realloc_cell(z, olen, len, what)
@@ -1191,14 +1332,12 @@ void must_realloc_cell(z, olen, len, what)
 #ifdef SHORT_SIZET
   ASSERT(len==size, MAKINUM(len), NALLOC, what);
 #endif
-  if (nm <= mtrigger)
-    SYSCALL(ptr = (char *)realloc(where, size););
-  else
-    ptr = 0;
-  if (!ptr)
-    ptr = igc_for_alloc(where, olen, size, what);
-  else
-    mallocated = nm;
+  ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what);
+/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */
+  if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
+  else ptr = 0;
+  if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
+  else mallocated = nm;
   SETCHARS(z, ptr);
 }
 void must_free(obj, len)
@@ -1209,6 +1348,7 @@ void must_free(obj, len)
 #ifdef CAREFUL_INTS
     while (len--) obj[len] = '#';
 #endif
+/* printf("free(%lx)\n", obj); fflush(stdout); */
     free(obj);
     mallocated = mallocated - len;
   }
@@ -1243,7 +1383,7 @@ SCM intern(name, len)
   register sizet i = len;
   register unsigned char *tmp = (unsigned char *)name;
   sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
-  /* printf("intern %s len=%d\n",name,len);fflush(stdout); */
+  /* printf("intern %s len=%d\n",name,len); fflush(stdout); */
   DEFER_INTS;
   for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
     z = CAR(lsym);
@@ -1256,8 +1396,7 @@ SCM intern(name, len)
   trynext: ;
   }
   /*  lsym = makfromstr(name, len); */
-  lsym = must_malloc_cell(len+1L,
-			  MAKE_LENGTH((long)len, tc7_msymbol), s_string);
+  lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string);
   i = len;
   CHARS(lsym)[len] = 0;
   while (i--) CHARS(lsym)[i] = name[i];
@@ -1284,16 +1423,15 @@ SCM sysintern(name, val)
     if (LENGTH(z) != len) goto trynext;
     for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
     lsym = CAR(lsym);
-    if (!UNBNDP(val))
-      CDR(lsym) = val;
+    if (!UNBNDP(val)) CDR(lsym) = val;
+    else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym)))
+      scm_gc_protect(lsym);
     return lsym;
   trynext: ;
   }
   NEWCELL(lsym);
-  DEFER_INTS;
-  SETLENGTH(lsym, (long)len, tc7_ssymbol);
+  SETLENGTH(lsym, len, tc7_ssymbol);
   SETCHARS(lsym, name);
-  ALLOW_INTS;
   lsym = cons(lsym, val);
   z = cons(lsym, UNDEFINED);
   CDR(z) = VELTS(symhash)[hash];
@@ -1350,7 +1488,7 @@ SCM makstr(len)
 	return s;
 }
 
-scm_gra subr_table_gra;
+scm_gra subrs_gra;
 SCM scm_maksubr(name, type, fcn)
      const char *name;
      int type;
@@ -1360,7 +1498,7 @@ SCM scm_maksubr(name, type, fcn)
 	int isubr;
 	register SCM z;
 	info.name = name;
-	isubr = scm_grow_gra(&subr_table_gra, (char *)&info);
+	isubr = scm_grow_gra(&subrs_gra, (char *)&info);
 	NEWCELL(z);
 	if (!fcn && tc7_cxr==type) {
 	  const char *p = name;
@@ -1484,7 +1622,7 @@ SCM scm_make_cont()
 #else
   from[1] = BOOL_F;		/* Can't write to parent stack */
   estk = must_malloc_cell((long)n*sizeof(SCM),
-			  MAKE_LENGTH((long)n, tc7_vector), s_cont);
+			  MAKE_LENGTH(n, tc7_vector), s_cont);
   {
     SCM *to = VELTS(estk);
     while(n--) to[n] = from[n];
@@ -1500,6 +1638,10 @@ SCM scm_make_cont()
   ncont->other.stkframe[1] = scm_env_tmp;
   ncont->other.estk = estk;
   ncont->other.estk_ptr = scm_estk_ptr;
+#ifndef RECKLESS
+  ncont->other.stkframe[2] = scm_trace_env;
+  ncont->other.stkframe[3] = scm_trace;
+#endif
   return cont;
 }
 static char s_sstale[] = "strangely stale";
@@ -1521,14 +1663,17 @@ void scm_dynthrow(tocont, val)
       SCM *from =  VELTS(cont->other.estk);
       SCM *to = VELTS(scm_estk);
       sizet n = LENGTH(cont->other.estk);
-      if (LENGTH(scm_estk) < n)
-	scm_estk_reset((sizet)LENGTH(scm_estk));
+      if (LENGTH(scm_estk) < n) scm_estk_reset((sizet)LENGTH(scm_estk));
       scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
       while(n--) to[n] = from[n];
     }
 #endif
     scm_env = cont->other.stkframe[0];
     scm_env_tmp = cont->other.stkframe[1];
+#ifndef RECKLESS
+    scm_trace_env = cont->other.stkframe[2];
+    scm_trace = cont->other.stkframe[3];
+#endif
     ALLOW_INTS;
   }
   throw_to_continuation(cont, val, CONT(rootcont));
@@ -1621,6 +1766,24 @@ static void fixconfig(s1, s2, s)
   quit(MAKINUM(1L));
 }
 
+void heap_report()
+{
+  sizet i = 0;
+  if (hplim_ind) lputs("; heap segments:", sys_errp);
+  while(i < hplim_ind) {
+    {
+      long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
+      lputs("\n; 0x", sys_errp);
+      intprint((long)hplims[i++], -16, sys_errp);
+      lputs(" - 0x", sys_errp);
+      intprint((long)hplims[i++], -16, sys_errp);
+      lputs("; ", sys_errp);
+      intprint(seg_cells, 10, sys_errp);
+      lputs(" cells; ", sys_errp);
+      intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
+      lputs(".kiB", sys_errp);
+    }}
+}
 sizet init_heap_seg(seg_org, size)
      CELLPTR seg_org;
      sizet size;
@@ -1641,6 +1804,8 @@ sizet init_heap_seg(seg_org, size)
   hplims[ni++] = seg_end;
   ptr = CELL_UP(ptr);
   ni = seg_end - ptr;
+/* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */
+/* printf("ptr = %lx\n", ptr); */
   for (i = ni;i--;ptr++) {
 #ifdef POINTERS_MUNGED
     scmptr = PTR2SCM(ptr);
@@ -1696,12 +1861,12 @@ void scm_init_gra(gra, eltsize, len, maxlen, what)
      char *what;
 {
   char *nelts;
-  DEFER_INTS;
+  /* DEFER_INTS; */
   /* Can't call must_malloc, because heap may not be initialized yet. */
   /*  SYSCALL(nelts = malloc(len*eltsize););
       if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what);
       mallocated += len*eltsize;
- */
+  */
   nelts = must_malloc((long)len*eltsize, what);
   gra->eltsize = eltsize;
   gra->len = 0;
@@ -1709,7 +1874,7 @@ void scm_init_gra(gra, eltsize, len, maxlen, what)
   gra->alloclen = len;
   gra->maxlen = maxlen;
   gra->what = what;
-  ALLOW_INTS;
+  /* ALLOW_INTS; */
 }
 /* Returns the index into the elt array */
 int scm_grow_gra(gra, elt)
@@ -1718,12 +1883,11 @@ int scm_grow_gra(gra, elt)
 {
   int i;
   char *tmp;
-  DEFER_INTS;
   if (gra->alloclen <= gra->len) {
     sizet inc = gra->len / 5 + 1;
     sizet nlen = gra->len + inc;
     if (gra->maxlen && nlen > gra->maxlen)
-      growerr: wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
+      /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
     /*
       SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
       if (!tmp) goto growerr;
@@ -1738,9 +1902,22 @@ int scm_grow_gra(gra, elt)
   gra->len += 1;
   for (i = 0; i < gra->eltsize; i++)
     tmp[i] = elt[i];
-  ALLOW_INTS;
   return gra->len - 1;
 }
+void scm_trim_gra(gra)
+     scm_gra *gra;
+{
+  char *tmp;
+  long curlen = gra->len;
+  if (0L==curlen) curlen = 1L;
+  if (curlen==(long)gra->alloclen) return;
+  tmp = must_realloc(gra->elts,
+		     (long)gra->alloclen * gra->eltsize,
+		     curlen * gra->eltsize,
+		     gra->what);
+  gra->elts = tmp;
+  gra->alloclen = curlen;
+}
 void scm_free_gra(gra)
      scm_gra *gra;
 {
@@ -1748,6 +1925,26 @@ void scm_free_gra(gra)
   gra->elts = 0;
   mallocated -= gra->maxlen*gra->eltsize;
 }
+void gra_report1(gra)
+     scm_gra *gra;
+{
+  intprint((long)gra->len, -10, cur_errp);
+  lputs(" (of ", cur_errp);
+  intprint((long)gra->alloclen, -10, cur_errp);
+  lputs(") ", cur_errp);
+  lputs(gra->what, cur_errp);
+  lputs("; ", cur_errp);
+}
+void gra_report()
+{
+  lputs(";; gra: ", cur_errp);
+  gra_report1(&ptobs_gra);
+  gra_report1(&smobs_gra);
+  gra_report1(&finals_gra);
+  gra_report1(&subrs_gra);
+  lputs("\n", cur_errp);
+}
+
 scm_gra smobs_gra;
 long newsmob(smob)
      smobfuns *smob;
@@ -1760,38 +1957,35 @@ long newptob(ptob)
 {
   return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob);
 }
-#define PORT_TABLE_MAXLEN (1 + ((int)((unsigned long)~0L>>20)))
 port_info *scm_port_table = 0;
-static int scm_port_table_len = 0;
+static sizet scm_port_table_len = 0;
 static char s_port_table[] = "port table";
-SCM scm_port_entry(ptype, flags)
+SCM scm_port_entry(stream, ptype, flags)
+     FILE *stream;
      long ptype, flags;
 {
-  int nlen;
+  SCM z;
+  sizet nlen;
   int i, j;
   VERIFY_INTS("scm_port_entry", 0L);
   flags = flags | (ptype & ~0xffffL);
   ASSERT(flags, INUM0, ARG1, "scm_port_entry");
-  for (i = 0; i < scm_port_table_len; i++)
+  for (i = 1; i < scm_port_table_len; i++)
     if (0L==scm_port_table[i].flags) goto ret;
-  if (0==scm_port_table_len) {	/* Initialize */
-    scm_port_table_len = 16;
-    scm_port_table = (port_info *)
-      must_malloc((long)scm_port_table_len*sizeof(port_info), s_port_table);
-  }
-  else if (scm_port_table_len < PORT_TABLE_MAXLEN) {
+  if (scm_port_table_len <= SCM_PORTNUM_MAX) {
     nlen = scm_port_table_len + (scm_port_table_len / 2);
-    if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN;
+    if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1;
     scm_port_table = (port_info *)
       must_realloc((char *)scm_port_table,
-		   (long)scm_port_table_len*sizeof(port_info),
-		   nlen*sizeof(port_info)+0L,
+		   (long)scm_port_table_len * sizeof(port_info),
+		   (long)nlen * sizeof(port_info),
 		   s_port_table);
     scm_port_table_len = nlen;
-    growth_mon(s_port_table, nlen+0L, "entries", !0);
+    growth_mon(s_port_table, nlen + 0L, "entries", !0);
     for (j = i; j < scm_port_table_len; j++) {
       scm_port_table[j].flags = 0L;
-      scm_port_table[j].data = EOL;
+      scm_port_table[j].data = UNDEFINED;
+      scm_port_table[j].port = UNDEFINED;
     }
   }
   else {
@@ -1801,12 +1995,27 @@ SCM scm_port_entry(ptype, flags)
     wta(UNDEFINED, s_nogrow, s_port_table);
   }
  ret:
+  NEWCELL(z);
+  SETSTREAM(z, stream);
+  CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype;
   scm_port_table[i].unread = EOF;
   scm_port_table[i].flags = flags;
   scm_port_table[i].line = 1L;	/* should both be one-based? */
   scm_port_table[i].col = 1;
   scm_port_table[i].data = UNSPECIFIED;
-  return (((long)i)<<20) | (flags & 0x0f0000) | ptype;
+  scm_port_table[i].port = z;
+  return z;
+}
+SCM scm_open_ports()
+{
+  SCM p, res = EOL;
+  int k;
+  for(k = scm_port_table_len - 1; k > 0; k--) {
+    p = scm_port_table[k].port;
+    if (NIMP(p) && OPPORTP(p))
+      res = cons(p, res);
+  }
+  return res;
 }
 
 SCM markcdr(ptr)
@@ -1888,8 +2097,10 @@ void init_storage(stack_start_ptr, init_heap_size)
 	hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
 	if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
 	j = init_heap_size;
+/*  	printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */
 	if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
 	  j = HEAP_SEG_SIZE;
+/*  	  printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */
 	  if (!init_heap_seg((CELLPTR) malloc(j), j))
 	    wta(MAKINUM(j), (char *)NALLOC, s_heap);
 	}
@@ -1897,12 +2108,37 @@ void init_storage(stack_start_ptr, init_heap_size)
 	heap_org = CELL_UP(hplims[0]);
 		/* hplims[0] can change. do not remove heap_org */
 
-	NEWCELL(def_inp);
-	CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG);
-	SETSTREAM(def_inp, stdin);
-	NEWCELL(def_outp);
-	CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED);
-	SETSTREAM(def_outp, stdout);
+	scm_port_table_len = 16;
+	scm_port_table = (port_info *)
+	  must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table);
+	for (j = 0; j < scm_port_table_len; j++) {
+	  scm_port_table[j].flags = 0L;
+	  scm_port_table[j].data = UNDEFINED;
+	  scm_port_table[j].port = UNDEFINED;
+	}
+
+	nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string);
+	CHARS(nullstr)[0] = 0;
+	nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector);
+	{
+	  long i = symhash_dim;
+	  SCM *velts;
+	  symhash = must_malloc_cell(i * sizeof(SCM),
+				     MAKE_LENGTH(i, tc7_vector),
+				     s_vector);
+	  velts = VELTS(symhash);
+	  while(--i >= 0) (velts)[i] = EOL;
+	}
+	/* Now that symhash is setup, we can sysintern() */
+	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
+	def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG);
+	SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED));
+	def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED);
+	SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED));
 	NEWCELL(def_errp);
 	CAR(def_errp) = (tc16_fport|OPN|WRTNG);
 	SETSTREAM(def_errp, stderr);
@@ -1922,17 +2158,6 @@ void init_storage(stack_start_ptr, init_heap_size)
 	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 */
 	/* Set up environment cache */
 	scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
@@ -2014,8 +2239,9 @@ jump_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 mark_subr_table P((void));
+static void mark_subrs P((void));
 static void sweep_symhash P((SCM v));
+static void mark_finalizers P((SCM *live, SCM *dead));
 static void mark_port_table P((SCM port));
 static void sweep_port_table P((void));
 static void egc_mark P((void));
@@ -2032,6 +2258,49 @@ SCM gc(arg)
   ALLOW_INTS;
   return UNSPECIFIED;
 }
+
+void scm_run_finalizers(exiting)
+     int exiting;
+{
+  SCM f;
+  if (exiting) {		/* run all finalizers, we're going home. */
+    DEFER_INTS;
+    while NIMP(gc_finalizers) {
+      f = CAR(gc_finalizers);
+      CAR(f) = CDR(f);
+      CDR(f) = gc_finalizers_pending;
+      gc_finalizers_pending = f;
+      gc_finalizers = CDR(gc_finalizers);
+    }
+    ALLOW_INTS;
+  }
+  while (!0) {
+    DEFER_INTS;
+    if NIMP(gc_finalizers_pending) {
+      f = CAR(gc_finalizers_pending);
+      gc_finalizers_pending = CDR(gc_finalizers_pending);
+    }
+    else f = BOOL_F;
+    ALLOW_INTS;
+    if IMP(f) break;
+    apply(f, EOL, EOL);
+  }
+}
+
+static SCM *loc_gc_hook = 0;
+void scm_gc_hook ()
+{
+  if (gc_hook_active) {
+    scm_warn("gc-hook thrashing?\n", "", UNDEFINED);
+    return;
+  }
+  gc_hook_active = !0;
+  if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED));
+  if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL);
+  scm_run_finalizers(0);
+  gc_hook_active = 0;
+}
+
 void igc(what, stackbase)
      char *what;
      STACKITEM *stackbase;
@@ -2043,8 +2312,7 @@ void igc(what, stackbase)
   if (err) wta(MAKINUM(err), "malloc corrupted", what);
 #endif
   gc_start(what);
-  if (errjmp_bad)
-    wta(UNDEFINED, s_recursive, s_gc);
+  if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc);
   errjmp_bad = s_gc;
 #ifdef NO_SYM_GC
   gc_mark(symhash);
@@ -2057,7 +2325,7 @@ void igc(what, stackbase)
   /* mark_sym_values() can be called anytime after mark_syms.  */
   mark_sym_values(symhash);
 #endif
-  mark_subr_table();
+  mark_subrs();
   egc_mark();
   if (stackbase) {
     FLUSH_REGISTER_WINDOWS;
@@ -2088,6 +2356,7 @@ void igc(what, stackbase)
   }
   while(j--)
     gc_mark(sys_protects[j]);
+  mark_finalizers(&gc_finalizers, &gc_finalizers_pending);
 #ifndef NO_SYM_GC
   sweep_symhash(symhash);
 #endif
@@ -2102,12 +2371,15 @@ void igc(what, stackbase)
     growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
     growth_mon(s_heap, heap_cells, s_cells, grewp);
   }
+  gc_hook_pending = !0;
+  deferred_proc = process_signals;
 }
 
 static char s_not_free[] = "not freed";
 void free_storage()
 {
   DEFER_INTS;
+  loc_gc_hook = (SCM *)0;
   gc_start("free");
   errjmp_bad = "free_storage";
   cur_inp = BOOL_F; cur_outp = BOOL_F;
@@ -2137,7 +2409,7 @@ void free_storage()
   hplims = 0;
   scm_free_gra(&finals_gra);
   scm_free_gra(&smobs_gra);
-  scm_free_gra(&subr_table_gra);
+  scm_free_gra(&subrs_gra);
   gc_end();
   ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
   exit_report();
@@ -2302,7 +2574,7 @@ void mark_locations(x, n)
 	register int i, j;
 	register CELLPTR ptr;
 	while(0 <= --m) if CELLP(*(SCM **)&x[m]) {
-		ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m]));
+		ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m]));
 		i = 0;
 		j = hplim_ind;
 		do {
@@ -2332,10 +2604,10 @@ static void gc_sweep(contin_bad)
   long pre_m = mallocated;
   sizet i = 0;
   sizet seg_cells;
-  while (i<hplim_ind) {
+  while (i < hplim_ind) {
     ptr = CELL_UP(hplims[i++]);
     seg_cells = CELL_DN(hplims[i++]) - ptr;
-    for(j = seg_cells;j--;++ptr) {
+    for(j = seg_cells; j--; ++ptr) {
 #ifdef POINTERS_MUNGED
       scmptr = PTR2SCM(ptr);
 #endif
@@ -2397,12 +2669,8 @@ static void gc_sweep(contin_bad)
 	goto freechars;
       case tc7_contin:
 	if GC8MARKP(scmptr) {
-	  if (contin_bad && CONT(scmptr)->length) {
-	    scm_warn("uncollected ", (char *)0);
-	    iprin1(scmptr, cur_errp, 1);
-	    lputc('\n', cur_errp);
-	    lfflush(cur_errp);
-	  }
+	  if (contin_bad && CONT(scmptr)->length)
+	    scm_warn("uncollected ", "", scmptr);
 	  goto c8mrkcontinue;
 	}
 	minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
@@ -2456,8 +2724,8 @@ static void gc_sweep(contin_bad)
 	  default:
 	    goto sweeperr;
 	  }
-#endif /* def FLOATS */
 	  break;
+#endif /* def FLOATS */
 	default:
 	  if GC8MARKP(scmptr) goto c8mrkcontinue;
 	  {
@@ -2580,10 +2848,59 @@ static void sweep_symhash(v)
 }
 #endif
 
-static void mark_subr_table()
+/* This function should be called after all other marking is done. */
+static void mark_finalizers(finalizers, pending)
+     SCM *finalizers, *pending;
+{
+  SCM lst, elt, v;
+  SCM live = EOL, undead = *finalizers;
+  int more_to_do = !0;
+  gc_mark(*pending);
+  while NIMP(*pending) pending = &CDR(*pending);
+  while (more_to_do) {
+    more_to_do = 0;
+    lst = undead;
+    undead = EOL;
+    while (NIMP(lst)) {
+      elt = CAR(lst);
+      v = CAR(elt);
+      switch (TYP3(v)) {
+      default:
+	if (GCMARKP(v)) goto marked;
+	goto unmarked;
+      case tc3_tc7_types:
+	if (GC8MARKP(v)) {
+	marked:
+	  gc_mark(CDR(elt));
+	  more_to_do = !0;
+	  v = lst;
+	  lst = CDR(lst);
+	  CDR(v) = live;
+	  live = v;
+	}
+	else {
+	unmarked:
+	  v = lst;
+	  lst = CDR(lst);
+	  CDR(v) = undead;
+	  undead = v;
+	}
+	break;
+      }
+    }
+  }
+  gc_mark(live);
+  for (lst = undead; NIMP(lst); lst = CDR(lst))
+    CAR(lst) = CDR(CAR(lst));
+  gc_mark(undead);
+  *finalizers = live;
+  *pending = undead;
+}
+
+static void mark_subrs()
 {
-  subr_info *table = subr_table;
-  int k = subr_table_gra.len;
+  /* subr_info *table = subrs; */
+  /* int k = subrs_gra.len; */
   /* while (k--) { } */
 }
 static void mark_port_table(port)
@@ -2606,7 +2923,8 @@ static void sweep_port_table()
       scm_port_table[k].flags &= (~1L);
     else {
       scm_port_table[k].flags = 0L;
-      scm_port_table[k].data = EOL;
+      scm_port_table[k].data = UNDEFINED;
+      scm_port_table[k].port = UNDEFINED;
     }
   }
 }
@@ -2732,9 +3050,9 @@ static void egc_copy_roots()
 				   non-cache cell was made to point into the
 				   cache. */
       if ECACHEP(x) break;
-      e = CDR(x);
+      e = CAR(x);
       if (NIMP(e) && ECACHEP(e))
-	egc_copy(&(CDR(x)));
+	egc_copy(&(CAR(x)));
       break;
     default:
       if (tc7_contin==TYP7(x)) {
diff --git a/time.c b/time.c
index 9d3be9a..7cefb94 100644
--- a/time.c
+++ b/time.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -103,12 +103,26 @@
 # include <sys/timeb.h>
 # define USE_GETTIMEOFDAY
 #endif
+#ifdef __MACH__
+# define unix
+# include <sys/types.h>
+# include <sys/time.h>
+# include <sys/timeb.h>
+# include <sys/times.h>
+# define USE_GETTIMEOFDAY
+#endif
 #ifdef __FreeBSD__
 # include <sys/types.h>
 # include <sys/time.h>
 # include <sys/timeb.h>
 # define USE_GETTIMEOFDAY
 #endif
+#ifdef __OpenBSD__
+# include <sys/types.h>
+# include <sys/time.h>
+# include <sys/timeb.h>
+# define USE_GETTIMEOFDAY
+#endif
 #ifdef __TURBOC__
 # define LACK_TIMES
 #endif
@@ -130,9 +144,13 @@
 #ifdef SVR4
 # define LACK_FTIME
 #endif
-#ifdef __svr4__
+#ifdef __SVR4
 # define LACK_FTIME
 #endif
+#ifdef PLAN9
+#define LACK_FTIME
+#define LACK_TIMES
+#endif
 #ifdef nosve
 # define LACK_FTIME
 #endif
@@ -160,7 +178,7 @@
 #ifdef _UNICOS
 # define LACK_FTIME
 #endif
-#ifdef __amigados__
+#ifdef __amigaos__
 # include <sys/time.h>
 # include <sys/timeb.h>
 # include <sys/times.h>
@@ -168,7 +186,7 @@
 #endif
 
 #ifndef LACK_FTIME
-# ifdef unix
+# ifdef HAVE_UNIX
 #  ifndef GO32
 #   include <sys/timeb.h>
 #  endif
@@ -199,7 +217,7 @@
 #ifdef CLK_TCK
 # define CLKTCK CLK_TCK
 # ifdef CLOCKS_PER_SEC
-#  ifdef unix
+#  ifdef HAVE_UNIX
 #   ifndef ARM_ULIB
 #    include <sys/times.h>
 #   endif
@@ -335,7 +353,8 @@ SCM your_time()
   else if ((1 + time_buffer1.time)==time_buffer2.time) ;
   else if (cnt < TIMETRIES) goto tryagain;
   else {
-    scm_warn("could not read two ftime()s within one second in 10 tries",0L);
+    scm_warn("could not read two ftime()s within one second in 10 tries",
+	     "", UNDEFINED);
     return MAKINUM(-1);
   }
   tmp = CLKTCK*(time_buffer2.millitm - your_base.millitm);
diff --git a/unexalpha.c b/unexalpha.c
index 2adfd1f..69db5fd 100644
--- a/unexalpha.c
+++ b/unexalpha.c
@@ -20,7 +20,15 @@ the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 Boston, MA 02111-1307, USA.  */
 
 
-#include <config.h>
+#ifndef emacs
+# ifndef __ELF__
+  /* Describe layout of the address space in an executing process.  */
+#  define TEXT_START    0x120000000
+#  define DATA_START    0x140000000
+# endif
+#else
+# include <config.h>
+#endif
 #include <sys/types.h>
 #include <sys/file.h>
 #include <sys/stat.h>
@@ -93,7 +101,7 @@ struct headers {
 /* Define name of label for entry point for the dumped executable.  */
 
 #ifndef DEFAULT_ENTRY_ADDRESS
-#define DEFAULT_ENTRY_ADDRESS __start
+# define DEFAULT_ENTRY_ADDRESS __start
 #endif
 
 unexec (new_name, a_name, data_start, bss_start, entry_address)
@@ -194,10 +202,10 @@ unexec (new_name, a_name, data_start, bss_start, entry_address)
 #endif
 #ifdef _PDATA
   CHECK_SCNHDR (pdata_section, _PDATA, STYP_PDATA);
-#endif _PDATA
+#endif /* _PDATA */
 #ifdef _GOT
   CHECK_SCNHDR (got_section,   _GOT,   STYP_GOT);
-#endif _GOT
+#endif /* _GOT */
   CHECK_SCNHDR (data_section,  _DATA,  STYP_DATA);
 #ifdef _XDATA
   CHECK_SCNHDR (xdata_section, _XDATA, STYP_XDATA);
@@ -315,7 +323,7 @@ unexec (new_name, a_name, data_start, bss_start, entry_address)
 	 "writing data section to %s", new_name);
 
 #ifdef _GOT
-#define old_got_section ((struct scnhdr *)buffer)
+# define old_got_section ((struct scnhdr *)buffer)
 
   if (got_section != NULL)
     {
@@ -327,7 +335,7 @@ unexec (new_name, a_name, data_start, bss_start, entry_address)
 	    "seeking to end of data section of %s", new_name);
     }
 
-#undef old_got_section
+# undef old_got_section
 #endif
 
   /*
@@ -408,10 +416,10 @@ update_dynamic_symbols (old, new_name, new, aout)
 
     x = ds_base[rd_base[i].index];
 
-#if 0
+# if 0
       fprintf (stderr, "Object inspected: %s, addr = %lx, shndx = %x",
 	       old + dynstr_section->s_scnptr + x.st_name, rd_base[i].addr, x.st_shndx);
-#endif
+# endif
 
 
     if ((ELF32_ST_BIND (x.st_info) == STB_GLOBAL)
@@ -433,13 +441,13 @@ update_dynamic_symbols (old, new_name, new, aout)
       unsigned long newref = aout.tsize + reladdr;
       int len;
 
-#if 0
+# if 0
       fprintf (stderr, "...relocated\n");
-#endif
+# endif
 
-      if (rd_base[i].type == R_REFLONG) 
+      if (rd_base[i].type == R_REFLONG)
 	len = 4;
-      else if (rd_base[i].type == R_REFQUAD) 
+      else if (rd_base[i].type == R_REFQUAD)
 	len = 8;
       else
 	fatal_unexec ("unrecognized relocation type in .dyn.rel section (symbol #%d)", i);
@@ -448,10 +456,10 @@ update_dynamic_symbols (old, new_name, new, aout)
       WRITE (new, oldref, len, "writing old dynrel info in %s", new_name);
     }
 
-#if 0
+# if 0
     else
       fprintf (stderr, "...not relocated\n");
-#endif
+# endif
 
   }
 
diff --git a/unexelf.c b/unexelf.c
index 60e82cc..ea8019f 100644
--- a/unexelf.c
+++ b/unexelf.c
@@ -522,7 +522,7 @@ unexec (new_name, old_name, data_start, bss_start, entry_address)
   Elf32_Off  new_data2_offset;
   Elf32_Addr new_data2_addr;
 
-  int n, nn, old_bss_index, old_data_index, new_data2_index;
+  int n, nn, old_bss_index, old_data_index;
   struct stat stat_buf;
 
   /* Open the old file & map it into the address space. */
diff --git a/unif.c b/unif.c
index 88250c2..ae5c1b7 100644
--- a/unif.c
+++ b/unif.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 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
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -61,7 +61,6 @@ complex double		cvect
 #endif
 
 long tc16_array = 0;
-static SCM i_short;
 
 char s_resizuve[] = "vector-set-length!";
 SCM resizuve(vect, len)
@@ -112,7 +111,7 @@ SCM resizuve(vect, len)
   siz = l * sz;
   if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve);
   DEFER_INTS;
-  must_realloc_cell(vect, (long)ol*sz, (long)siz, s_resizuve);
+  must_realloc_cell(vect, ol*sz, (long)siz, s_resizuve);
   if VECTORP(vect)
     while(l > ol)
       VELTS(vect)[--l] = UNSPECIFIED;
@@ -149,34 +148,22 @@ long scm_prot2type(prot)
 {
   if (BOOL_T==prot) return tc7_bvect;
   if ICHRP(prot) return tc7_string;
-  if INUMP(prot)
-    return INUM(prot)>0 ? tc7_uvect : tc7_ivect;
-  if (i_short==prot) return tc7_svect;
+  if (MAKINUM(32L)==prot) return tc7_uvect;
+  if (MAKINUM(-32L)==prot) return tc7_ivect;
+  if (MAKINUM(-16L)==prot) return tc7_svect;
+  if INUMP(prot) return INUM(prot) > 0 ? tc7_uvect : tc7_ivect;
   if IMP(prot) return tc7_vector;
 # ifdef FLOATS
   if INEXP(prot) {
     double x;
-    float fx;
     if CPLXP(prot) return tc7_cvect;
     x = REALPART(prot);
-    fx = x;
-    return (x == fx) ? tc7_fvect : tc7_dvect;
-  }
-# endif
-# ifdef BIGDIG
-  if (TYP16(prot)==tc16_bigpos) {
-    if (DIGSPERLONG < NUMDIGS(prot)) return tc7_vector;
-    return tc7_uvect;
-  }
-  if (TYP16(prot)==tc16_bigneg) {
-    long res = 0;
-    sizet l = NUMDIGS(prot);
-    if (DIGSPERLONG < l) return tc7_vector;
-    for(;l--;) res = BIGUP(res) + BDIGITS(prot)[l];
-    if (0>=res) return tc7_vector;
-    return tc7_ivect;
+    if (32.0==x) return tc7_fvect;
+    if (64.0==x) return tc7_dvect;
+    return tc7_dvect;
   }
 # endif
+  return tc7_vector;
 }
 
 SCM make_uve(k, prot)
@@ -216,34 +203,21 @@ SCM make_uve(k, prot)
   }
   DEFER_INTS;
   v = must_malloc_cell((i ? i : 1L),
-		       MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type),
+		       MAKE_LENGTH((k < LENGTH_MAX ? k : LENGTH_MAX), type),
 		       s_vector);
   if (tc7_string==type) CHARS(v)[k] = 0;
   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_vector:
-  case tcs_uves:
-    return MAKINUM(LENGTH(v));
-  }
-}
-
 SCM arrayp(v, prot)
      SCM v, prot;
 {
   int enclosed = 0;
   long typ;
   if IMP(v) return BOOL_F;
-  typ = TYP7(v);
  loop:
+  typ = TYP7(v);
   switch (typ) {
   case tc7_smob: if (!ARRAYP(v)) return BOOL_F;
     if (UNBNDP(prot)) return BOOL_T;
@@ -866,7 +840,7 @@ SCM aref(v, args)
     int k = ARRAY_NDIM(v);
     SCM res = make_ra(k);
     if (!ARRAYP(v)) {
-      ASRTGO(NULLP(args),badarg);
+      ASRTGO(NULLP(args), badarg);
       return v;
     }
     ARRAY_V(res) = ARRAY_V(v);
@@ -1125,7 +1099,7 @@ SCM uve_read(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);
+  ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
   ASRTGO(NIMP(v), badarg1);
   len = LENGTH(v);
  loop:
@@ -1190,7 +1164,7 @@ SCM uve_write(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);
+  ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
   ASRTGO(NIMP(v), badarg1);
   len = LENGTH(v);
  loop:
@@ -1233,7 +1207,7 @@ SCM uve_write(v, port)
     break;
 # endif
   }
-  SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port)););
+  ans = lfwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, port);
   if (TYP7(v)==tc7_bvect) ans *= LONG_BIT;
   return MAKINUM(ans);
 }
@@ -1299,7 +1273,7 @@ SCM lcount(item, seq)
   }
 }
 static char s_uve_pos[] = "bit-position";
-SCM position(item, v, k)
+SCM bit_position(item, v, k)
      SCM item, v, k;
 {
   long i, len, lenw, xbits, pos = INUM(k), offset = 0;
@@ -1669,10 +1643,9 @@ SCM list2ura(ndim, prot, lst)
   SCM shp=EOL;
   SCM row=lst;
   SCM ra;
-  sizet k;
   long n;
+  sizet k = INUM(ndim);
   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);
@@ -1879,18 +1852,18 @@ int raprin1(exp, port, writing)
   case tc7_string:
     lputs("A\\", port); break;
   case tc7_uvect:
-    lputs("Au", port); break;
+    lputs("Au32", port); break;
   case tc7_ivect:
-    lputs("Ae", port); break;
+    lputs("As32", port); break;
   case tc7_svect:
-    lputs("Aes", port); break;
+    lputs("As16", port); break;
 # ifdef FLOATS
   case tc7_fvect:
-    lputs("Aif", port); break;
+    lputs("Ar32", port); break;
   case tc7_dvect:
-    lputs("Ai", port); break;
+    lputs("Ar64", port); break;
   case tc7_cvect:
-    lputs("Aic", port); break;
+    lputs("Ac64", port); break;
 # endif /*FLOATS*/
   }
   if ((v != exp) && 0==ARRAY_NDIM(exp)) {
@@ -1921,13 +1894,13 @@ SCM array_prot(ra)
   case tc7_vector: return EOL;
   case tc7_bvect: return BOOL_T;
   case tc7_string: return MAKICHR('a');
-  case tc7_svect: return i_short;
-  case tc7_uvect: return MAKINUM(1L);
-  case tc7_ivect: return MAKINUM(-1L);
+  case tc7_uvect: return MAKINUM(32L);
+  case tc7_ivect: return MAKINUM(-32L);
+  case tc7_svect: return MAKINUM(-16L);
 # ifdef FLOATS
-  case tc7_fvect: return makflo(1.0);
-  case tc7_dvect: return makdbl(1.0/3.0, 0.0);
-  case tc7_cvect: return makdbl(0.0, 1.0);
+  case tc7_fvect: return makflo(32.0);
+  case tc7_dvect: return makdbl(64.0, 0.0);
+  case tc7_cvect: return makdbl(0.0, 64.0);
 # endif
   }
 }
@@ -2007,23 +1980,21 @@ SCM scm_logaset(ra, obj, args)
     else if (BOOL_F==obj)
       obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
 	scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
-#ifndef RECKLESS
+# ifndef RECKLESS
     else wta(obj, (char *)ARG2, s_logaset);
-#endif
+# endif
   }
   return aset(ra, obj, inds);
 }
 
 static iproc subr3s[] = {
-	{"uniform-vector-set1!", aset},
-	{s_uve_pos, position},
+	{s_uve_pos, bit_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},
@@ -2033,7 +2004,6 @@ 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},
@@ -2059,8 +2029,6 @@ static iproc lsubr2s[] = {
 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)
@@ -2071,7 +2039,8 @@ static SCM markra(ptr)
 static sizet freera(ptr)
      CELLPTR ptr;
 {
-  must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
+  must_free(CHARS((SCM)ptr),
+	    sizeof(array) + ARRAY_NDIM((SCM)ptr)*sizeof(array_dim));
   return 0;
 }
 static smobfuns rasmob = {markra, freera, raprin1, 0};
@@ -2087,9 +2056,7 @@ void init_unif()
   init_iprocs(lsubr2s, tc7_lsubr_2);
   init_iprocs(subr2os, tc7_subr_2o);
   tc16_array = newsmob(&rasmob);
-  i_short = CAR(sysintern("exact-short", UNDEFINED));
   add_feature(s_array);
-  add_feature("string-case");
 }
 
 #else /* ARRAYS */
diff --git a/unix.c b/unix.c
index dca9099..3cfc809 100644
--- a/unix.c
+++ b/unix.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -49,8 +49,15 @@
 /* #include <sys/wait.h> */
 #include <sys/stat.h>
 
+extern SCM stat2scm P((struct stat *stat_temp));
 
-SCM	stat2scm P((struct stat *stat_temp));
+SCM scm_mknod P((SCM path, SCM mode, SCM dev));
+SCM scm_acct P((SCM path));
+SCM scm_nice P((SCM incr));
+SCM scm_sync P((void));
+SCM scm_symlink P((SCM oldpath, SCM newpath));
+SCM scm_readlink P((SCM path));
+SCM scm_lstat P((SCM str));
 
 #ifndef STDC_HEADERS
 	void sync P((void));
@@ -62,13 +69,16 @@ SCM	stat2scm P((struct stat *stat_temp));
 # ifdef SVR4
 #  include <unistd.h>
 # endif
+# ifdef __OpenBSD__
+#  include <unistd.h>
+# endif
 #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 scm_mknod(path, mode, dev)
      SCM path, mode, dev;
 {
   int val;
@@ -79,7 +89,7 @@ SCM l_mknod(path, mode, dev)
   return val ? BOOL_F : BOOL_T;
 }
 static char s_acct[] = "acct";
-SCM l_acct(path)
+SCM scm_acct(path)
      SCM path;
 {
   int val;
@@ -93,21 +103,21 @@ SCM l_acct(path)
 }
 
 static char s_nice[] = "nice";
-SCM l_nice(incr)
+SCM scm_nice(incr)
      SCM incr;
 {
   ASSERT(INUMP(incr), incr, ARG1, s_nice);
   return nice(INUM(incr)) ? BOOL_F : BOOL_T;
 }
 
-SCM l_sync()
+SCM scm_sync()
 {
   sync();
   return UNSPECIFIED;
 }
 
 static char s_symlink[] = "symlink";
-SCM l_symlink(oldpath, newpath)
+SCM scm_symlink(oldpath, newpath)
      SCM oldpath, newpath;
 {
   int val;
@@ -117,7 +127,7 @@ SCM l_symlink(oldpath, newpath)
   return val ? BOOL_F : BOOL_T;
 }
 static char s_readlink[] = "readlink";
-SCM l_readlink(path)
+SCM scm_readlink(path)
   SCM path;
 {
   int i;
@@ -128,7 +138,7 @@ SCM l_readlink(path)
   return makfromstr(buf, (sizet)i);
 }
 static char s_lstat[] = "lstat";
-SCM l_lstat(str)
+SCM scm_lstat(str)
   SCM str;
 {
   int i;
@@ -140,17 +150,17 @@ SCM l_lstat(str)
 }
 
 static iproc subr1s[] = {
-	{s_nice, l_nice},
-	{s_acct, l_acct},
-	{s_lstat, l_lstat},
-	{s_readlink, l_readlink},
+	{s_nice, scm_nice},
+	{s_acct, scm_acct},
+	{s_lstat, scm_lstat},
+	{s_readlink, scm_readlink},
 	{0, 0}};
 
 void init_unix()
 {
-	make_subr("sync", tc7_subr_0, l_sync);
+	make_subr("sync", tc7_subr_0, scm_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);
+	make_subr(s_symlink, tc7_subr_2, scm_symlink);
+	make_subr(s_mknod, tc7_subr_3, scm_mknod);
 	add_feature("unix");
 }
diff --git a/x.c b/x.c
index 6070ef2..8b3a53c 100644
--- a/x.c
+++ b/x.c
@@ -15,26 +15,26 @@
  * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  *
  * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
  *
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM 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.
+ * linking the SCM 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
+ * Free Software Foundation under the name SCM.  If you copy
  * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, 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
+ * If you write modifications of your own for SCM, it is your choice
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.
  */
@@ -57,7 +57,10 @@
 #include <stdio.h>
 #include <X11/X.h>
 #include <X11/Xlib.h>
+#include <X11/Xcms.h>
+/*#include <X11/Xcmsint.h>*/	/* For IntensityTbl */
 #include <X11/Xutil.h>
+#include <X11/Xatom.h>
 
 #include "scm.h"
 
@@ -150,9 +153,12 @@ struct display_screen{
 #define XCOLORMAP(x)	(COLORMAP(x)->cm)
 #define XGCONDISPLAY(x)	(GCONTEXT(x)->dpy)
 
-/* Notice that types Visual and XEvent don't have struct wrappers. */
+/* Notice that types XVisualInfo, XcmsCCC, and XEvent don't have
+   struct wrappers. */
 
-#define XVISUAL(x)	((Visual *)		CDR(x))
+#define XVISUALINFO(x)	((XVisualInfo *)	CDR(x))
+#define XVISUAL(x)	(XVISUALINFO(x)->visual)
+#define XCCC(x)		((XcmsCCC)		CDR(x))
 #define XEVENT(x)	((XEvent *)		CDR(x))
 
 			/* Type predicates */
@@ -163,6 +169,7 @@ struct display_screen{
 #define OPWINDOWP(x)	(((0xffff | OPN) & (int)CAR(x))==(tc16_xwindow | OPN))
 #define COLORMAPP(x)	(TYP16(x)==tc16_xcolormap)
 #define GCONTEXTP(x)	(TYP16(x)==tc16_xgcontext)
+#define CCCP(x)		(TYP16(x)==tc16_xccc)
 #define CURSORP(x)	(TYP16(x)==tc16_xcursor)
 #define FONTP(x)	(TYP16(x)==tc16_xfont)
 #define VISUALP(x)	(TYP16(x)==tc16_xvisual)
@@ -178,13 +185,16 @@ static char s_x_root_window[]		= "x:root-window";
 static char s_x_default_gcontext[]	= "x:default-gc";
 static char s_x_default_visual[]	= "x:default-visual";
 static char s_x_default_colormap[]	= "x:default-colormap";
+static char s_x_default_ccc[]		= "x:default-ccc";
+/* static char s_x_ccc_screen_info[]	= "x:ccc-screen-info"; */
 static char s_x_create_window[]		= "x:create-window";
 static char s_x_window_set[]		= "x:window-set!";
-/*  static char s_x_window_ref[]		= "x:window-ref"; */
+static char s_x_window_ref[]		= "x:window-ref";
 static char s_x_create_pixmap[]		= "x:create-pixmap";
+static char s_x_get_window_property[]	= "x:get-window-property";
+static char s_x_list_properties[]	= "x:list-properties";
 
 static char s_x_map_window[]		= "x:map-window";
-static char s_x_map_raised[]		= "x:map-raised";
 static char s_x_map_subwindows[]	= "x:map-subwindows";
 static char s_x_unmap_window[]		= "x:unmap-window";
 static char s_x_unmap_subwindows[]	= "x:unmap-subwindows";
@@ -215,7 +225,10 @@ static char s_x_screen_dimm[]		= "x:screen-dimensions";
 static char s_x_screen_white[]		= "x:screen-white";
 static char s_x_screen_black[]		= "x:screen-black";
 static char s_x_make_visual[]		= "x:make-visual";
+static char s_x_visual_class[]		= "x:visual-class";
+static char s_x_visual_geometry[]	= "x:visual-geometry";
 static char s_x_window_geometry[]	= "x:window-geometry";
+static char s_x_window_geometry_set[]	= "x:window-geometry-set!";
 
 static char s_x_create_colormap[]	= "x:create-colormap";
 static char s_x_recreate_colormap[]	= "x:copy-colormap-and-free";
@@ -225,6 +238,8 @@ static char s_x_find_color[]		= "x:colormap-find-color";
 static char s_x_color_set[]		= "x:colormap-set!";
 static char s_x_color_ref[]		= "x:colormap-ref";
 static char s_x_install_colormap[]	= "x:install-colormap";
+/*  static char s_x_colormap_basis[]	= "x:colormap-basis"; */
+/*  static char s_x_colormap_limits[]	= "x:colormap-limits"; */
 
 static char s_x_clear_area[]		= "x:clear-area";
 static char s_x_fill_rectangle[]	= "x:fill-rectangle";
@@ -238,6 +253,7 @@ static char s_x_image_string[]		= "x:image-string";
 
 static char s_x_flush[]			= "x:flush";
 static char s_x_event_ref[]		= "x:event-ref";
+static char s_x_event_keysym[]		= "x:event->keysym";
 
 		       /* Type-name strings */
 
@@ -247,6 +263,7 @@ static char s_gc[]	= "graphics-context";
 #define s_cursor   (&s_x_create_cursor[9])
 #define s_font     (&s_x_load_font[7])
 #define s_colormap (&s_x_create_colormap[9])
+#define s_visual   (&s_x_make_visual[7])
 
 	   /* Scheme (SMOB) types defined in this module */
 
@@ -258,6 +275,8 @@ long tc16_xcursor;
 long tc16_xfont;
 long tc16_xvisual;
 long tc16_xevent;
+long tc16_xccc;
+XContext xtc_ccc, xtc_cmp;
 
 /* We use OPN (which is already defined and used for PTOB ports) to
    keep track of whether objects of types Display and Window are open.
@@ -327,6 +346,9 @@ SCM make_xcolormap(sdpy, cmp)
 {
   SCM z;
   struct xs_Colormap *xcm;
+  XPointer scmptr;
+  if (!XFindContext(XDISPLAY(sdpy), (XID)cmp, xtc_cmp, &scmptr))
+    return (SCM)scmptr;
   DEFER_INTS;
   z = must_malloc_cell((long)sizeof(struct xs_Colormap),
 		       (SCM)tc16_xcolormap,
@@ -335,14 +357,18 @@ SCM make_xcolormap(sdpy, cmp)
   xcm->display = sdpy;
   xcm->dpy = DISPLAY(xcm->display)->dpy;
   xcm->cm = cmp;
+  XSaveContext(XDISPLAY(sdpy), (XID)cmp, xtc_cmp, z);
   ALLOW_INTS;
   return z;
 }
 static SCM mark_xcolormap(ptr)
      SCM ptr;
 {
+  struct xs_Colormap *xcm;
   if CLOSEDP(ptr) return BOOL_F;
-  return COLORMAP(ptr)->display;
+  xcm = COLORMAP(ptr);
+  gc_mark(CCC2SCM_P(XcmsCCCOfColormap(xcm->dpy, xcm->cm)));
+  return xcm->display;
 }
 static sizet free_xcolormap(ptr)
      CELLPTR ptr;
@@ -385,10 +411,10 @@ SCM make_xdisplay(d)
       make_xwindow(z, idx, RootWindow(d, idx), (char) 0, (char) 1);
     scrns[idx].default_gcontext =
       make_xgcontext(z, idx, XDefaultGC(d, idx), !0);
+    scrns[idx].default_visual =
+      make_xvisual(visual2visualinfo(d, DefaultVisual(d, idx)));
     scrns[idx].default_colormap =
       make_xcolormap(z, DefaultColormap(d, idx));
-    scrns[idx].default_visual =
-      make_xvisual(DefaultVisual(d, idx));
   }
   return z;
 }
@@ -401,10 +427,12 @@ static SCM mark_xdisplay(ptr)
     struct xs_screen *scrns = (struct xs_screen *)(xsd + 1);
     int idx = xsd->screen_count;
     while (--idx) {
+      SCM scmp = scrns[idx].default_colormap;
       gc_mark(scrns[idx].root_window);
       gc_mark(scrns[idx].default_gcontext);
       gc_mark(scrns[idx].default_visual);
-      gc_mark(scrns[idx].default_colormap);
+      gc_mark(scmp);
+      gc_mark (CCC2SCM_P(XcmsCCCOfColormap(xsd->dpy, XCOLORMAP(scmp))));
     }
     gc_mark(scrns[idx].root_window);
     gc_mark(scrns[idx].default_gcontext);
@@ -549,7 +577,7 @@ static sizet free_xfont(ptr)
 }
 
 SCM make_xvisual(vsl)
-     Visual *vsl;
+     XVisualInfo *vsl;
 {
   SCM s_vsl;
   NEWCELL(s_vsl);
@@ -560,6 +588,37 @@ SCM make_xvisual(vsl)
   return s_vsl;
 }
 
+SCM CCC2SCM_P(ccc)
+     XcmsCCC ccc;
+{
+  XPointer scmptr;
+  if (XFindContext(ccc->dpy, (XID)ccc, xtc_ccc, &scmptr))
+    return BOOL_F;
+  return (SCM)scmptr;
+}
+SCM CCC2SCM(ccc)
+     XcmsCCC ccc;
+{
+  SCM s_ccc = CCC2SCM_P(ccc);
+  if FALSEP(s_ccc) {
+    NEWCELL(s_ccc);
+    DEFER_INTS;
+    CAR(s_ccc) = tc16_xccc;
+    SETCDR(s_ccc, ccc);
+    XSaveContext(ccc->dpy, (XID)ccc, xtc_ccc, s_ccc);
+    ALLOW_INTS;
+  }
+  return s_ccc;
+}
+static sizet free_xccc(ptr)
+     CELLPTR ptr;
+{
+  XcmsCCC ccc = XCCC((SCM)ptr);
+  XDeleteContext(ccc->dpy, (XID)ccc, xtc_ccc);
+  XcmsFreeCCC(ccc);
+  return 0;
+}
+
 SCM make_xevent(e)
 XEvent *e;
 {
@@ -571,7 +630,7 @@ XEvent *e;
   NEWCELL(w);
   DEFER_INTS;
   CAR(w) = tc16_xevent;
-  SETCDR(w,ec);
+  SETCDR(w, ec);
   ALLOW_INTS;
   return w;
 }
@@ -683,7 +742,7 @@ int scm2xpointslen(sara, s_caller)
 	&& (1==adm[1].inc)
 	&& ARRAY_CONTP(sara)
 	&& (tc7_svect==TYP7(ARRAY_V(sara))))) return -1;
-  len = adm[0].ubnd - adm[0].lbnd;
+  len = 1 + adm[0].ubnd - adm[0].lbnd;
   if (len < 0) return 0;
   return len;
 }
@@ -719,7 +778,7 @@ SCM thevalue(obj)
      SCM obj;
 {
   if (NIMP(obj) && SYMBOLP(obj))
-    return ceval(obj, (SCM)EOL);
+    return ceval(obj, (SCM)EOL, (SCM)EOL);
   else return obj;
 }
 
@@ -780,15 +839,16 @@ int theuint(obj, s_caller)
   return INUM(val);
 }
 
-static int args2xgcvalmask(oargs)
+static int args2valmask(oargs, s_caller)
      SCM oargs;
+     char *s_caller;
 {
   SCM args = oargs;
   int attr, len, attr_mask = 0;
   if (!(len = ilength(args))) return 0;
   while (len) {
-    ASSERT(NIMP(args), oargs, WNA, s_gc);
-    attr = theint(CAR(args), s_gc); args = CDR(args);
+    ASSERT(NIMP(args), oargs, WNA, s_caller);
+    attr = theint(CAR(args), s_caller); args = CDR(args);
     attr_mask |= attr;
     len -= 1;
   }
@@ -904,6 +964,36 @@ static int args2winattribs(vlu, oargs)
   }
   return attr_mask;
 }
+static int args2wincfgs(vlu, oargs)
+     XWindowChanges *vlu;
+     SCM oargs;
+{
+  SCM sval, args = oargs;
+  int cfgs, len, cfgs_mask = 0;
+  /* (void)memset((char *)vlu, 0, sizeof(XWindowChanges)); */
+  if (!(len = ilength(args))) return 0;
+  ASSERT(len > 0 && (! (len & 1)), oargs, WNA, s_window);
+  while (len) {
+    ASSERT(NIMP(args), oargs, WNA, s_window);
+    cfgs = theint(CAR(args), s_window); args = CDR(args);
+    ASSERT(NIMP(args), oargs, WNA, s_window);
+    sval = CAR(args); args = CDR(args);
+    cfgs_mask |= cfgs;
+    switch (cfgs) {
+
+    case CWX:		vlu->x		      = theuint(sval, s_window); break;
+    case CWY:		vlu->y		      = theuint(sval, s_window); break;
+    case CWWidth:	vlu->width	      = theuint(sval, s_window); break;
+    case CWHeight:	vlu->height	      = theuint(sval, s_window); break;
+    case CWBorderWidth:	vlu->border_width     = theuint(sval, s_window); break;
+    case CWSibling:	vlu->sibling          =thepxmap(sval, s_window); break;
+    case CWStackMode:	vlu->stack_mode       =  theint(sval, s_window); break;
+    default: ASSERT(0, MAKINUM(cfgs), ARGn, s_window);
+    }
+    len -= 2;
+  }
+  return cfgs_mask;
+}
 
 		   /* Scheme-visible procedures */
 
@@ -1012,6 +1102,47 @@ SCM x_create_pixmap(obj, s_size, s_depth)
   p = XCreatePixmap(dpy, drawable, size.x, size.y, depth);
   return make_xwindow(display, scn, p, (char) 1, (char) 0);
 }
+SCM x_window_ref(oargs)
+     SCM oargs;
+{
+  SCM swn, args = oargs, sval = BOOL_F;
+  SCM vals = cons(BOOL_T, EOL), valend = vals;
+  struct xs_Window *xwn;
+  XWindowAttributes vlu;
+  int attr, len = ilength(args);
+  /* (void)memset((char *)&vlu, 0, sizeof(XWindowAttributes)); */
+  ASSERT(len > 0, oargs, WNA, s_x_window_ref);
+  if (1==len--) return EOL;
+  swn = CAR(args); args = CDR(args);
+  ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_ref);
+  xwn = WINDOW(swn);
+  if (!XGetWindowAttributes(xwn->dpy, xwn->p.win, &vlu)) return BOOL_F;
+  while (len) {
+    attr = theint(CAR(args), s_x_window_ref); args = CDR(args);
+    switch (attr) {
+
+    case CWBackPixel:	 sval = MAKINUM(vlu.backing_pixel); break;
+    case CWBitGravity:	 sval = MAKINUM(vlu.bit_gravity); break;
+    case CWWinGravity:	 sval = MAKINUM(vlu.win_gravity); break;
+    case CWBackingStore: sval = MAKINUM(vlu.backing_store); break;
+    case CWBackingPlanes:sval = MAKINUM(vlu.backing_planes); break;
+    case CWBackingPixel: sval = MAKINUM(vlu.backing_pixel); break;
+    case CWOverrideRedirect:sval = x_make_bool(vlu.override_redirect); break;
+    case CWSaveUnder:	 sval = x_make_bool(vlu.save_under); break;
+    case CWEventMask:	 sval = MAKINUM(vlu.your_event_mask); break;
+    case CWDontPropagate:sval = MAKINUM(vlu.do_not_propagate_mask); break;
+    case CWColormap:	 sval = make_xcolormap(xwn->display, vlu.colormap); break;
+
+    default: ASSERT(0, MAKINUM(attr), ARGn, s_x_window_ref);
+    }
+    CAR(valend) = sval;
+    CDR(valend) = cons(BOOL_T, EOL);
+    len -= 1;
+    if (len) valend = CDR(valend);
+    else CDR(valend) = EOL;
+  }
+  return vals;
+}
 SCM x_window_set(args)
      SCM args;
 {
@@ -1047,6 +1178,22 @@ SCM x_window_geometry(swin)
 	       cons2(MAKINUM(w), MAKINUM(h), EOL),
 	       cons2(MAKINUM(border_width), MAKINUM(depth), EOL));
 }
+SCM x_window_geometry_set(args)
+     SCM args;
+{
+  SCM swn;
+  struct xs_Window *xwn;
+  XWindowChanges vlu;
+  unsigned long mask;
+
+  ASSERT(NIMP(args), args, WNA, s_x_window_geometry_set);
+  swn = CAR(args); args = CDR(args);
+  ASSERT(NIMP(swn) && WINDOWP(swn), swn, ARG1, s_x_window_geometry_set);
+  xwn = WINDOW(swn);
+  mask = args2wincfgs(&vlu, args);
+  XConfigureWindow(xwn->dpy, xwn->p.win, mask, &vlu);
+  return UNSPECIFIED;
+}
 
 SCM x_close(obj)
      SCM obj;
@@ -1121,6 +1268,25 @@ SCM x_install_colormap(s_cm, s_flg)
   XInstallColormap(XDISPLAY(xcm->display), xcm->cm);
   return UNSPECIFIED;
 }
+/*  SCM x_colormap_basis(svsl) */
+/*       SCM svsl; */
+/*  { */
+/*    XColormapInfo *vsl; */
+/*    ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_basis); */
+/*    vsl = XCOLORMAPINFO(svsl); */
+/*    return cons2(vsl->red_mult, vsl->green_mult, */
+/*  	       cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
+/*  } */
+/*  SCM x_colormap_limits(svsl) */
+/*       SCM svsl; */
+/*  { */
+/*    XColormapInfo *vsl; */
+/*    ASSERT(NIMP(svsl) && COLORMAPP(svsl), svsl, ARG1, s_x_colormap_limits); */
+/*    vsl = XCOLORMAPINFO(svsl); */
+/*    return cons2(vsl->red_mult, vsl->green_mult, */
+/*  	       cons2(vsl->blue_mult, vsl->base_pixel, EOL)); */
+/*  } */
+
 		       /* Colors in Colormap */
 
 SCM x_alloc_color_cells(scmap, spxls, sargs)
@@ -1246,15 +1412,6 @@ SCM x_map_window(swin)
   XMapWindow(w->dpy, w->p.win);
   return UNSPECIFIED;
 }
-SCM x_map_raised(swin)
-     SCM swin;
-{
-  struct xs_Window *w;
-  ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_raised);
-  w = WINDOW(swin);
-  XMapRaised(w->dpy, w->p.win);
-  return UNSPECIFIED;
-}
 SCM x_map_subwindows(swin)
      SCM swin;
 {
@@ -1332,7 +1489,7 @@ SCM x_copy_gc(dst, src, args)
   ASSERT(NIMP(src) && GCONTEXTP(src), src, ARG2, s_x_copy_gc);
   dgc = GCONTEXT(dst);
   sgc = GCONTEXT(src);
-  mask = args2xgcvalmask(args);
+  mask = args2valmask(args, s_gc);
   XCopyGC(dgc->dpy, sgc->gc, mask, dgc->gc);
   return UNSPECIFIED;
 }
@@ -1349,8 +1506,9 @@ SCM x_gc_ref(oargs)
   ASSERT(len > 0, oargs, WNA, s_x_gc_ref);
   if (1==len--) return EOL;
   sgc = CAR(args); args = CDR(args);
+  ASSERT(NIMP(sgc) && GCONTEXTP(sgc), sgc, ARG1, s_x_gc_ref);
   xgc = GCONTEXT(sgc);
-  valuemask = args2xgcvalmask(args);
+  valuemask = args2valmask(args, s_gc);
 /*    printf("valuemask = %lx\n", valuemask); */
   valuemask &= (GCFunction | GCPlaneMask | GCForeground | GCBackground |
 		GCLineWidth | GCLineStyle | GCCapStyle | GCJoinStyle |
@@ -1399,8 +1557,9 @@ SCM x_gc_ref(oargs)
     }
     CAR(valend) = sval;
     CDR(valend) = cons(BOOL_T, EOL);
-    valend = CDR(valend);
     len -= 1;
+    if (len) valend = CDR(valend);
+    else CDR(valend) = EOL;
   }
   return vals;
 }
@@ -1575,6 +1734,8 @@ SCM x_screen_depth(sd, si)
      SCM sd, si;
 {
   struct display_screen dspscn;
+  if (UNBNDP(si) && NIMP(sd) && VISUALP(sd))
+    return MAKINUM(XVISUALINFO(sd)->depth);
   scm2display_screen(sd, si, &dspscn, s_x_screen_depth);
   return MAKINUM(DisplayPlanes(dspscn.dpy, dspscn.screen_number));
 }
@@ -1630,20 +1791,65 @@ SCM x_screen_white(sd, si)
   return ulong2num(WhitePixelOfScreen(scn));
 }
 
+XVisualInfo *visual2visualinfo(dsp, vis)
+     Display *dsp;
+     Visual *vis;
+{
+  int nitems_return;
+  XVisualInfo vinfo_template;
+  XVisualInfo *vislst;
+  vinfo_template.visualid = XVisualIDFromVisual(vis);
+  vislst = XGetVisualInfo(dsp, VisualIDMask, &vinfo_template, &nitems_return);
+  if (1 != nitems_return) {
+    if (vislst) XFree(vislst);
+    wta(MAKINUM(nitems_return), (char *)WNA, s_visual);
+  }
+  return vislst;
+}
 SCM x_make_visual(sd, sdepth, sclass)
      SCM sd, sdepth, sclass;
 {
+  int nitems_return;
   struct display_screen dspscn;
-  XVisualInfo vis;
-  Status sts;
+  XVisualInfo vinfo_template;
+  XVisualInfo *vislst;
   scm2display_screen(sd, UNDEFINED, &dspscn, s_x_make_visual);
-  sts = XMatchVisualInfo(dspscn.dpy, dspscn.screen_number,
-			 theuint(sdepth, s_x_make_visual),
-			 theuint(sclass, s_x_make_visual),
-			 &vis);
-  if (!sts) return BOOL_F;
-  return make_xvisual(vis.visual);
+  vinfo_template.screen = dspscn.screen_number;
+  vinfo_template.depth = theuint(sdepth, s_x_make_visual);
+  vinfo_template.class = theuint(sclass, s_x_make_visual);
+  vislst =
+    XGetVisualInfo(dspscn.dpy,
+		   VisualScreenMask | VisualDepthMask | VisualClassMask,
+		   &vinfo_template,
+		   &nitems_return);
+  if (0==nitems_return) return BOOL_F;
+  return make_xvisual(vislst);
+}
+static sizet free_visual(ptr)
+     CELLPTR ptr;
+{
+  XFree(XVISUALINFO(ptr));
+  return 0;
+}
+SCM x_visual_geometry(svsl)
+     SCM svsl;
+{
+  XVisualInfo *vsl;
+  ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_geometry);
+  vsl = XVISUALINFO(svsl);
+  return cons2(MAKINUM(vsl->red_mask), MAKINUM(vsl->green_mask),
+	       cons2(MAKINUM(vsl->blue_mask), MAKINUM(vsl->colormap_size),
+		     EOL));
+}
+SCM x_visual_class(svsl)
+     SCM svsl;
+{
+  XVisualInfo *vsl;
+  ASSERT(NIMP(svsl) && VISUALP(svsl), svsl, ARG1, s_x_visual_class);
+  vsl = XVISUALINFO(svsl);
+  return MAKINUM(vsl->class);
 }
+
 SCM x_root_window(sdpy, sscr)
      SCM sdpy, sscr;
 {
@@ -1688,6 +1894,151 @@ SCM x_default_visual(sdpy, sscr)
   scrns = (struct xs_screen *)(xsd + 1);
   return scrns[dspscn.screen_number].default_visual;
 }
+SCM x_default_ccc(sdpy, sscr)
+     SCM sdpy, sscr;
+{
+  struct display_screen dspscn;
+  XcmsCCC ccc;
+  if (NIMP(sdpy) && COLORMAPP(sdpy) && UNBNDP(sscr)) {
+    struct xs_Colormap *cmp = COLORMAP(sdpy);
+    ccc = XcmsCCCOfColormap(cmp->dpy, cmp->cm);
+  }
+  else {
+    scm2display_screen(sdpy, sscr, &dspscn, s_x_default_ccc);
+    ccc = XcmsDefaultCCC(dspscn.dpy, dspscn.screen_number);
+  }
+  return CCC2SCM(ccc);
+}
+/*
+SCM x_ccc_screen_info(sccc, sfmt)
+     SCM sccc;
+     SCM sfmt;
+{
+  XcmsCCC xccc;
+  XcmsPerScrnInfo *pPerScrnInfo;
+  ASSERT(NIMP(sccc) && CCCP(sccc), sccc, ARG1, s_x_ccc_screen_info);
+  ASSERT(NIMP(sfmt) && STRINGP(sfmt), sfmt, ARG2, s_x_ccc_screen_info);
+  xccc = XCCC(sccc);
+  pPerScrnInfo = (XcmsFunctionSet *)xccc->pPerScrnInfo;
+  return ;
+}
+*/
+		       /* Window Information */
+
+SCM x_propdata2scm(type, format, nitems, data)
+     Atom type;
+     int format;
+     unsigned long nitems;
+     unsigned char* data;
+{
+  SCM datum = EOL;
+  SCM lst = EOL;
+  int cnt;
+  for (cnt = nitems; cnt--;) {
+    switch (type) {
+    case XA_ATOM:
+    case XA_VISUALID:
+    case XA_CARDINAL:
+      switch (format) {
+      case 8: datum = MAKINUM(((unsigned char *)data)[cnt]); break;
+      case 16: datum = MAKINUM(((unsigned short *)data)[cnt]); break;
+      case 32: datum = ulong2num(((unsigned long *)data)[cnt]); break;
+      default: return MAKINUM(format);
+      } break;
+    case XA_INTEGER:
+      switch (format) {
+      case 8: datum = MAKINUM(((char *)data)[cnt]); break;
+      case 16: datum = MAKINUM(((short *)data)[cnt]); break;
+      case 32: datum = long2num(((long *)data)[cnt]); break;
+      default: return MAKINUM(format);
+      } break;
+    case XA_STRING:
+      switch (format) {
+      case 8: return makfrom0str(data);
+      default: return MAKINUM(format);
+      } break;
+    case XA_ARC:
+    case XA_BITMAP:
+    case XA_COLORMAP:
+    case XA_CURSOR:
+    case XA_DRAWABLE:
+    case XA_FONT:
+    case XA_PIXMAP:
+    case XA_POINT:
+    case XA_RECTANGLE:
+    case XA_RGB_COLOR_MAP:
+    case XA_WINDOW:
+    case XA_WM_HINTS:
+    case XA_WM_SIZE_HINTS:
+    default:
+      /* datum = BOOL_F; */
+      return MAKINUM(-type);
+    }
+    lst = cons(datum, lst);
+  }
+  return lst;
+}
+SCM x_get_window_property(swin, sprop, sargs)
+     SCM swin, sprop, sargs;
+{
+  struct xs_Window *xwn;
+  Atom property;
+  Atom actual_type_return;
+  int actual_format_return;
+  unsigned long nitems_return;
+  unsigned long bytes_after_return;
+  unsigned char *prop_return;
+  int sarglen = ilength(sargs);
+  ASSERT(IMP(sprop) ? INUMP(sprop) : STRINGP(sprop),
+	 sprop, ARG2, s_x_get_window_property);
+  ASSERT(sarglen >= 0 && sarglen < 2, sargs, WNA, s_x_get_window_property);
+  if (1 == sarglen) {
+    ASSERT(NFALSEP(booleanp(CAR(sargs))), sargs, ARG3, s_x_get_window_property);
+  }
+  ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+  xwn = WINDOW(swin);
+  if (INUMP(sprop))
+    property = INUM(sprop);
+  else
+    property = XInternAtom(xwn->dpy, CHARS(sprop), !0);
+
+  if (None == property) return BOOL_F;
+  if (XGetWindowProperty(xwn->dpy, xwn->p.win, property, 0L, 65536L,
+			 (1 == sarglen) && NFALSEP(CAR(sargs)), AnyPropertyType,
+			 &actual_type_return, &actual_format_return,
+			 &nitems_return, &bytes_after_return,
+			 &prop_return)
+      != Success)
+    return BOOL_F;
+  {
+    SCM ans = x_propdata2scm(actual_type_return, actual_format_return,
+			     nitems_return, prop_return);
+    XFree(prop_return);
+    return ans;
+  }
+}
+SCM x_list_properties(swin)
+     SCM swin;
+{
+  struct xs_Window *xwn;
+  Atom *atoms;
+  int num_prop_return;
+  SCM lst;
+  ASSERT(NIMP(swin) && WINDOWP(swin), swin, ARG1, s_x_map_window);
+  xwn = WINDOW(swin);
+  atoms = XListProperties(xwn->dpy, xwn->p.win, &num_prop_return);
+  {
+    int i = num_prop_return;
+    lst = EOL;
+    while (i--) {
+      char *name = XGetAtomName(xwn->dpy, atoms[i]);
+      lst = cons(makfrom0str(name), lst);
+      XFree(name);
+    }
+  }
+  XFree(atoms);
+  return lst;
+}
 
 			   /* Rendering */
 
@@ -1856,6 +2207,24 @@ SCM x_fill_poly(sdbl, sgc, sargs)
   return xldraw_lines(sdbl, sgc, sargs, 2, s_x_fill_poly);
 }
 
+static char s_x_read_bitmap_file[]      = "x:read-bitmap-file";
+SCM x_read_bitmap_file(sdbl, sfname)
+     SCM sdbl, sfname;
+{
+  unsigned int w, h;
+  int x, y;
+  Pixmap pxmp;
+  ASSERT(NIMP(sdbl) && WINDOWP(sdbl), sdbl, ARG1, s_x_read_bitmap_file);
+  if (XReadBitmapFile(XWINDISPLAY(sdbl),
+		      WINDOW(sdbl)->p.pm,
+		      CHARS(sfname),
+		      &w, &h, &pxmp, &x, &y) == BitmapSuccess)
+    return make_xwindow(WINDOW(sdbl)->display,
+			WINDOW(sdbl)->screen_number,
+			pxmp, (char) 1, (char) 0);
+  else return BOOL_F;
+}
+
 			    /* XEvents */
 
 /* x_make_bool() is used in xevent.h */
@@ -1895,6 +2264,26 @@ static char *x__event_name(type)
     if (type==event_names[i].type) return event_names[i].name;
   return "unknown";
 }
+
+SCM x_event_keysym(sevent)
+     SCM sevent;
+{
+  XKeyEvent *ev;
+  KeySym ans;
+  ASRTGO(NIMP(sevent) && XEVENTP(sevent), badarg);
+  ev = (XKeyEvent *)CHARS(sevent);
+  switch (((XEvent*)ev)->type) {
+  badarg:
+  default: wta(sevent, (char *)ARG1, s_x_event_keysym);
+  case KeyPress:
+  case KeyRelease:
+    ;
+  }
+  ans = XLookupKeysym(ev, ev->state);
+  if (ans) return MAKINUM(ans);
+  else return BOOL_F;
+}
+
 		      /* SMOB print routines */
 
 static int print_xevent(exp, f, writing)
@@ -1972,13 +2361,56 @@ static int print_xgcontext(exp, f, writing)
   lputc('>', f);
   return 1;
 }
+
+char *xvisualclass2name(class)
+     int class;
+{
+  switch (class) {
+  case StaticGray: return "StaticGray";
+  case GrayScale: return "GrayScale";
+  case StaticColor: return "StaticColor";
+  case PseudoColor: return "PseudoColor";
+  case TrueColor: return "TrueColor";
+  case DirectColor: return "DirectColor";
+  default: return "??";
+  }
+}
+
 static int print_xvisual(exp, f, writing)
      SCM exp;
      SCM f;
      int writing;
 {
+  XVisualInfo *xvi = XVISUALINFO(exp);
   lputs("#<X visual #x", f);
-  intprint((long) XVisualIDFromVisual(XVISUAL(exp)), 16, f);
+  intprint((long) xvi->visualid, 16, f);
+  lputs(" ", f);
+  lputs(xvisualclass2name(xvi->class), f);
+  lputc(' ', f);
+  intprint((long) xvi->depth, 10, f);
+  lputc('x', f);
+  intprint((long) xvi->colormap_size, 10, f);
+  lputc('>', f);
+  return 1;
+}
+static int print_xccc(exp, f, writing)
+     SCM exp;
+     SCM f;
+     int writing;
+{
+  XcmsColorSpace **papColorSpaces;
+  XcmsCCC xccc = XCCC(exp);
+  lputs("#<X CCC", f);
+  papColorSpaces =
+    ((XcmsFunctionSet *)xccc->pPerScrnInfo->functionSet)->DDColorSpaces;
+  if (papColorSpaces != NULL) {
+    while (*papColorSpaces != NULL) {
+      lputs(" ", f);
+      lputs((*papColorSpaces)->prefix, f);
+      papColorSpaces++;
+    }
+  }
+
   lputc('>', f);
   return 1;
 }
@@ -1989,7 +2421,8 @@ static smobfuns smob_xcursor	= {mark_xcursor, free_xcursor, print_xcursor, 0};
 static smobfuns smob_xfont	= {mark_xfont, free_xfont, print_xfont, 0};
 static smobfuns smob_xgcontext	= {mark_xgcontext, free_xgcontext, print_xgcontext, 0};
 static smobfuns smob_xcolormap	= {mark_xcolormap, free_xcolormap, print_xcolormap, 0};
-static smobfuns smob_xvisual	= {mark0, free0, print_xvisual, 0};
+static smobfuns smob_xvisual	= {mark0, free_visual, print_xvisual, 0};
+static smobfuns smob_xccc	= {mark0, free_xccc, print_xccc, 0};
 static smobfuns smob_xevent	= {mark0, x_free_xevent, print_xevent, 0};
 
 static iproc x_subr3s[] = {
@@ -2005,6 +2438,7 @@ static iproc x_lsubr2s[] = {
   {s_x_create_cursor,		x_create_cursor},
   {s_x_alloc_color_cells,	x_alloc_color_cells},
   {s_x_free_color_cells,	x_free_color_cells},
+  {s_x_get_window_property,	x_get_window_property},
   {s_x_clear_area,		x_clear_area},
   {s_x_fill_rectangle,		x_fill_rectangle},
   {s_x_draw_string,		x_draw_string},
@@ -2022,7 +2456,8 @@ static iproc x_lsubrs[] = {
   {s_x_gc_ref,			x_gc_ref},
   {s_x_copy_gc,			x_copy_gc},
   {s_x_window_set,		x_window_set},
-/*    {s_x_window_ref,		x_window_ref}, */
+  {s_x_window_geometry_set,	x_window_geometry_set},
+  {s_x_window_ref,		x_window_ref},
   {0, 0}
 };
 
@@ -2031,6 +2466,7 @@ static iproc x_subr2s[] = {
   {s_x_find_color,		x_find_color},
   {s_x_color_ref,		x_color_ref},
   {s_x_load_font,		x_load_font},
+  {s_x_read_bitmap_file,        x_read_bitmap_file},
   {0, 0}
 };
 
@@ -2057,6 +2493,7 @@ static iproc x_subr2os[] = {
   {s_x_default_visual,		x_default_visual},
   {s_x_default_colormap,	x_default_colormap},
   {s_x_install_colormap,	x_install_colormap},
+  {s_x_default_ccc,		x_default_ccc},
   {s_x_flush,			x_flush},
   {0, 0}
 };
@@ -2066,12 +2503,17 @@ static iproc x_subr1s[] = {
   {s_x_close,			x_close},
   {s_x_default_screen,		x_default_screen},
   {s_x_window_geometry,		x_window_geometry},
+  {s_x_list_properties,		x_list_properties},
   {s_x_map_window,		x_map_window},
-  {s_x_map_raised,		x_map_raised},
   {s_x_map_subwindows,		x_map_subwindows},
   {s_x_unmap_window,		x_unmap_window},
   {s_x_unmap_subwindows,	x_unmap_subwindows},
   {s_x_recreate_colormap,	x_recreate_colormap},
+  {s_x_visual_geometry,		x_visual_geometry},
+  {s_x_visual_class,		x_visual_class},
+  {s_x_event_keysym,		x_event_keysym},
+/*    {s_x_colormap_basis,		x_colormap_basis}, */
+/*    {s_x_colormap_limits,		x_colormap_limits}, */
   {0, 0}
 };
 
@@ -2099,10 +2541,16 @@ void init_x()
   tc16_xgcontext = newsmob(&smob_xgcontext);
   tc16_xvisual = newsmob(&smob_xvisual);
   tc16_xevent = newsmob(&smob_xevent);
+  tc16_xccc = newsmob(&smob_xccc);
+  xtc_ccc = XUniqueContext();
+  xtc_cmp = XUniqueContext();
 
   scm_ldprog("x11.scm");
   scm_ldprog("xevent.scm");
-	scm_ldstr("\
+				/* Redefines STRING */
+/*    scm_ldprog("xatoms.scm"); */
+  scm_ldstr("\
+(define x:ccc x:default-ccc)\n\
 (define x:GC-Clip-Origin (logior x:GC-Clip-X-Origin x:GC-Clip-Y-Origin))\n\
 (define x:GC-Tile-Stip-Origin \n\
         (logior x:GC-Tile-Stip-X-Origin x:GC-Tile-Stip-Y-Origin))\n\
diff --git a/x.h b/x.h
index 1207e6a..4423211 100644
--- a/x.h
+++ b/x.h
@@ -5,7 +5,9 @@ SCM make_xdisplay(Display *d);
 SCM make_xgcontext(SCM d, int screen_number, GC gc, int rootp);
 SCM make_xcursor(SCM display, Cursor cursor);
 SCM make_xfont(SCM display, Font font, SCM name);
-SCM make_xvisual(Visual *vsl);
+SCM make_xvisual(XVisualInfo *vsl);
+SCM CCC2SCM_P(XcmsCCC ccc);
+SCM CCC2SCM(XcmsCCC ccc);
 SCM make_xevent(XEvent *e);
 size_t x_free_xevent(CELLPTR ptr);
 void scm2XPoint(int signp, SCM dat, XPoint *ipr, char *pos, char *s_caller);
@@ -25,8 +27,10 @@ SCM x_display_debug(SCM sd, SCM si);
 SCM x_default_screen(SCM sdpy);
 SCM x_create_window(SCM swin, SCM spos, SCM sargs);
 SCM x_create_pixmap(SCM obj, SCM s_size, SCM s_depth);
+SCM x_window_ref(SCM oargs);
 SCM x_window_set(SCM args);
 SCM x_window_geometry(SCM swin);
+SCM x_window_geometry_set(SCM args);
 SCM x_close(SCM obj);
 SCM x_flush(SCM sd, SCM si);
 SCM x_create_colormap(SCM swin, SCM s_vis, SCM s_alloc);
@@ -38,7 +42,6 @@ SCM x_find_color(SCM scmap, SCM dat);
 SCM x_color_set(SCM scmap, SCM s_pix, SCM dat);
 SCM x_color_ref(SCM scmap, SCM sidx);
 SCM x_map_window(SCM swin);
-SCM x_map_raised(SCM swin);
 SCM x_map_subwindows(SCM swin);
 SCM x_unmap_window(SCM swin);
 SCM x_unmap_subwindows(SCM swin);
@@ -65,14 +68,21 @@ SCM x_screen_size(SCM sd, SCM si);
 SCM x_screen_dimm(SCM sd, SCM si);
 SCM x_screen_black(SCM sd, SCM si);
 SCM x_screen_white(SCM sd, SCM si);
+XVisualInfo *visual2visualinfo(Display *dsp, Visual *vis);
 SCM x_make_visual(SCM sd, SCM sdepth, SCM sclass);
+SCM x_visual_geometry(SCM svsl);
+SCM x_visual_class(SCM svsl);
 SCM x_root_window(SCM sdpy, SCM sscr);
 SCM x_default_colormap(SCM sdpy, SCM sscr);
 SCM x_default_gcontext(SCM sdpy, SCM sscr);
 SCM x_default_visual(SCM sdpy, SCM sscr);
+SCM x_default_ccc(SCM sdpy, SCM sscr);
+SCM x_propdata2scm(Atom type, int format, unsigned long nitems, unsigned char *data);
+SCM x_get_window_property(SCM swin, SCM sprop, SCM sargs);
+SCM x_list_properties(SCM swin);
 SCM x_clear_area(SCM swin, SCM spos, SCM sargs);
 SCM x_fill_rectangle(SCM swin, SCM sgc, SCM sargs);
-void xldraw_string(SCM sdbl, SCM sgc, SCM sargs, int (*proc)(), char *s_caller);
+void xldraw_string(SCM sdbl, SCM sgc, SCM sargs, int (*proc)(void), char *s_caller);
 SCM x_draw_string(SCM sdbl, SCM sgc, SCM sargs);
 SCM x_image_string(SCM sdbl, SCM sgc, SCM sargs);
 SCM x_draw_points(SCM sdbl, SCM sgc, SCM sargs);
@@ -80,7 +90,10 @@ SCM xldraw_lines(SCM sdbl, SCM sgc, SCM sargs, int funcod, char *s_caller);
 SCM x_draw_segments(SCM sdbl, SCM sgc, SCM sargs);
 SCM x_draw_lines(SCM sdbl, SCM sgc, SCM sargs);
 SCM x_fill_poly(SCM sdbl, SCM sgc, SCM sargs);
+SCM x_read_bitmap_file(SCM sdbl, SCM sfname);
 SCM x_make_bool(int f);
 SCM x_event_ref(SCM sevent, SCM sfield);
+SCM x_event_keysym(SCM sevent);
+char *xvisualclass2name(int class);
 void x_scm_final(void);
 void init_x(void);
diff --git a/x11.scm b/x11.scm
index ee5fa32..7b49bf1 100644
--- a/x11.scm
+++ b/x11.scm
@@ -431,16 +431,16 @@
 (define x:Queued-After-Reading 1)
 (define x:Queued-After-Flush 2)
 (define x:All-Planes -1)
-(define x:XN-Required-Char-Set 134530035)
-(define x:XN-Query-Orientation 134530074)
-(define x:XN-Base-Font-Name 134530114)
-(define x:XNOM-Automatic 134530147)
-(define x:XN-Missing-Char-Set 134530176)
-(define x:XN-Default-String 134530213)
-(define x:XN-Orientation 134530247)
-(define x:XN-Directional-Dependent-Drawing 134530276)
-(define x:XN-Contextual-Drawing 134530339)
-(define x:XN-Font-Info 134530381)
+(define x:XN-Required-Char-Set 134529975)
+(define x:XN-Query-Orientation 134530014)
+(define x:XN-Base-Font-Name 134530054)
+(define x:XNOM-Automatic 134530087)
+(define x:XN-Missing-Char-Set 134530116)
+(define x:XN-Default-String 134530153)
+(define x:XN-Orientation 134530187)
+(define x:XN-Directional-Dependent-Drawing 134530216)
+(define x:XN-Contextual-Drawing 134530307)
+(define x:XN-Font-Info 134530349)
 (define x:XIM-Preedit-Area 1)
 (define x:XIM-Preedit-Callbacks 2)
 (define x:XIM-Preedit-Position 4)
@@ -450,48 +450,48 @@
 (define x:XIM-Status-Callbacks 512)
 (define x:XIM-Status-Nothing 1024)
 (define x:XIM-Status-None 2048)
-(define x:XN-Va-Nested-List 134530592)
-(define x:XN-Query-Input-Style 134530627)
-(define x:XN-Client-Window 134530666)
-(define x:XN-Input-Style 134530698)
-(define x:XN-Focus-Window 134530726)
-(define x:XN-Resource-Name 134530756)
-(define x:XN-Resource-Class 134530788)
-(define x:XN-Geometry-Callback 134530822)
-(define x:XN-Destroy-Callback 134530862)
-(define x:XN-Filter-Events 134530900)
-(define x:XN-Preedit-Start-Callback 134530932)
-(define x:XN-Preedit-Done-Callback 134530981)
-(define x:XN-Preedit-Draw-Callback 134531028)
-(define x:XN-Preedit-Caret-Callback 134531075)
-(define x:XN-Preedit-State-Notify-Callback 134531124)
-(define x:XN-Preedit-Attributes 134531186)
-(define x:XN-Status-Start-Callback 134531228)
-(define x:XN-Status-Done-Callback 134531275)
-(define x:XN-Status-Draw-Callback 134531320)
-(define x:XN-Status-Attributes 134531365)
-(define x:XN-Area 134531405)
-(define x:XN-Area-Needed 134531420)
-(define x:XN-Spot-Location 134531448)
-(define x:XN-Colormap 134531480)
-(define x:XN-Std-Colormap 134531503)
-(define x:XN-Foreground 134531533)
-(define x:XN-Background 134531560)
-(define x:XN-Background-Pixmap 134531587)
-(define x:XN-Font-Set 134531627)
-(define x:XN-Line-Space 134531649)
-(define x:XN-Cursor 134531675)
-(define x:XN-Query-IM-Values-List 134531694)
-(define x:XN-Query-IC-Values-List 134531738)
-(define x:XN-Visible-Position 134531782)
-(define x:XNR6-Preedit-Callback 134531820)
-(define x:XN-String-Conversion-Callback 134531862)
-(define x:XN-String-Conversion 134531919)
-(define x:XN-Reset-State 134531959)
-(define x:XN-Hot-Key 134531987)
-(define x:XN-Hot-Key-State 134532007)
-(define x:XN-Preedit-State 134532038)
-(define x:XN-Separatorof-Nested-List 134532070)
+(define x:XN-Va-Nested-List 134530560)
+(define x:XN-Query-Input-Style 134530595)
+(define x:XN-Client-Window 134530634)
+(define x:XN-Input-Style 134530666)
+(define x:XN-Focus-Window 134530694)
+(define x:XN-Resource-Name 134530724)
+(define x:XN-Resource-Class 134530756)
+(define x:XN-Geometry-Callback 134530790)
+(define x:XN-Destroy-Callback 134530830)
+(define x:XN-Filter-Events 134530868)
+(define x:XN-Preedit-Start-Callback 134530900)
+(define x:XN-Preedit-Done-Callback 134530949)
+(define x:XN-Preedit-Draw-Callback 134530996)
+(define x:XN-Preedit-Caret-Callback 134531043)
+(define x:XN-Preedit-State-Notify-Callback 134531092)
+(define x:XN-Preedit-Attributes 134531171)
+(define x:XN-Status-Start-Callback 134531213)
+(define x:XN-Status-Done-Callback 134531260)
+(define x:XN-Status-Draw-Callback 134531305)
+(define x:XN-Status-Attributes 134531350)
+(define x:XN-Area 134531390)
+(define x:XN-Area-Needed 134531405)
+(define x:XN-Spot-Location 134531433)
+(define x:XN-Colormap 134531465)
+(define x:XN-Std-Colormap 134531488)
+(define x:XN-Foreground 134531518)
+(define x:XN-Background 134531545)
+(define x:XN-Background-Pixmap 134531572)
+(define x:XN-Font-Set 134531612)
+(define x:XN-Line-Space 134531634)
+(define x:XN-Cursor 134531660)
+(define x:XN-Query-IM-Values-List 134531679)
+(define x:XN-Query-IC-Values-List 134531723)
+(define x:XN-Visible-Position 134531767)
+(define x:XNR6-Preedit-Callback 134531805)
+(define x:XN-String-Conversion-Callback 134531847)
+(define x:XN-String-Conversion 134531904)
+(define x:XN-Reset-State 134531944)
+(define x:XN-Hot-Key 134531972)
+(define x:XN-Hot-Key-State 134531992)
+(define x:XN-Preedit-State 134532023)
+(define x:XN-Separatorof-Nested-List 134532055)
 (define x:X-Buffer-Overflow -1)
 (define x:X-Lookup-None 1)
 (define x:X-Lookup-Chars 2)
@@ -522,7 +522,7 @@
 (define x:XIM-String-Conversion-Word 3)
 (define x:XIM-String-Conversion-Char 4)
 (define x:XIM-String-Conversion-Substitution 1)
-(define x:XIM-String-Conversion-Retrival 2)
+(define x:XIM-String-Conversion-Retrieval 2)
 (define x:XIM-Hot-Key-State-ON 1)
 (define x:XIM-Hot-Key-State-OFF 2)
 ;;inc2scm extracted #define values from /usr/include/X11/Xutil.h
diff --git a/xatoms.scm b/xatoms.scm
new file mode 100644
index 0000000..d6661c3
--- /dev/null
+++ b/xatoms.scm
@@ -0,0 +1,80 @@
+;; xgen.scm extracted definitions from /usr/include/X11/Xatom.h
+(define PRIMARY 1)
+(define SECONDARY 2)
+(define ARC 3)
+(define ATOM 4)
+(define BITMAP 5)
+(define CARDINAL 6)
+(define COLORMAP 7)
+(define CURSOR 8)
+(define CUT-BUFFER0 9)
+(define CUT-BUFFER1 10)
+(define CUT-BUFFER2 11)
+(define CUT-BUFFER3 12)
+(define CUT-BUFFER4 13)
+(define CUT-BUFFER5 14)
+(define CUT-BUFFER6 15)
+(define CUT-BUFFER7 16)
+(define DRAWABLE 17)
+(define FONT 18)
+(define INTEGER 19)
+(define PIXMAP 20)
+(define POINT 21)
+(define RECTANGLE 22)
+(define RESOURCE-MANAGER 23)
+(define RGB-COLOR-MAP 24)
+(define RGB-BEST-MAP 25)
+(define RGB-BLUE-MAP 26)
+(define RGB-DEFAULT-MAP 27)
+(define RGB-GRAY-MAP 28)
+(define RGB-GREEN-MAP 29)
+(define RGB-RED-MAP 30)
+(define STRING 31)
+(define VISUALID 32)
+(define WINDOW 33)
+(define WM-COMMAND 34)
+(define WM-HINTS 35)
+(define WM-CLIENT-MACHINE 36)
+(define WM-ICON-NAME 37)
+(define WM-ICON-SIZE 38)
+(define WM-NAME 39)
+(define WM-NORMAL-HINTS 40)
+(define WM-SIZE-HINTS 41)
+(define WM-ZOOM-HINTS 42)
+(define MIN-SPACE 43)
+(define NORM-SPACE 44)
+(define MAX-SPACE 45)
+(define END-SPACE 46)
+(define SUPERSCRIPT-X 47)
+(define SUPERSCRIPT-Y 48)
+(define SUBSCRIPT-X 49)
+(define SUBSCRIPT-Y 50)
+(define UNDERLINE-POSITION 51)
+(define UNDERLINE-THICKNESS 52)
+(define STRIKEOUT-ASCENT 53)
+(define STRIKEOUT-DESCENT 54)
+(define ITALIC-ANGLE 55)
+(define X-HEIGHT 56)
+(define QUAD-WIDTH 57)
+(define WEIGHT 58)
+(define POINT-SIZE 59)
+(define RESOLUTION 60)
+(define COPYRIGHT 61)
+(define NOTICE 62)
+(define FONT-NAME 63)
+(define FAMILY-NAME 64)
+(define FULL-NAME 65)
+(define CAP-HEIGHT 66)
+(define WM-CLASS 67)
+(define WM-TRANSIENT-FOR 68)
+(define LAST-PREDEFINED 68)
+;; xgen.scm extracted definitions from /usr/include/X11/Xcms.h
+(define	X:Undefined	#x00000000)
+(define	X:CIEXYZ	#x00000001)
+(define	X:CIEuvY	#x00000002)
+(define	X:CIExyY	#x00000003)
+(define	X:CIELab	#x00000004)
+(define	X:CIELuv	#x00000005)
+(define	X:TekHVC	#x00000006)
+(define	X:RGB	#x80000000)
+(define	X:RGBi	#x80000001)
diff --git a/xevent.h b/xevent.h
index 733c6c9..a74d533 100644
--- a/xevent.h
+++ b/xevent.h
@@ -1,4 +1,4 @@
-/* ./xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h */
+/* xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h */
 #ifdef SCM_EVENT_FIELDS
   case (KeyPress<<8)+0x10: case (KeyRelease<<8)+0x10: return MAKINUM(((XKeyEvent *) x)->type);
   case (KeyPress<<8)+0x11: case (KeyRelease<<8)+0x11: return MAKINUM(((XKeyEvent *) x)->serial);
diff --git a/xevent.scm b/xevent.scm
index 6436a36..c54e67c 100644
--- a/xevent.scm
+++ b/xevent.scm
@@ -1,4 +1,4 @@
-;; ./xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h
+;; xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h
 (define X-event:type #x10)
 (define X-event:serial #x11)
 (define X-event:send-event #x12)
diff --git a/xgen.scm b/xgen.scm
index 19db1cc..6c5bd4b 100755
--- a/xgen.scm
+++ b/xgen.scm
@@ -1,6 +1,6 @@
 #! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
 - !#
-;; Copyright (C) 1991-1999 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2000 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
@@ -17,26 +17,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM 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.
+;; linking the SCM 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
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, 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
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -44,8 +44,9 @@
 ;;; Author: Aubrey Jaffer.
 
 (define (go-script)
-  (cond ((not *script*))
+  (cond ;;((not *script*))
 	((>= 1 (- (length *argv*) *optind*))
+	 (xatoms)
 	 (apply xgen.scm (list-tail *argv* *optind*)))
 	(else
 	 (display "\
@@ -60,28 +61,14 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
 
 (require 'common-list-functions)
 (require 'string-search)
+(require 'string-case)
 (require 'line-i/o)
 (require 'printf)
 (require 'scanf)
 
-(define (StudlyCaps->dashed-name nstr)
-  (do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
-      ((> 2 idx))
-    (cond ((and (char-upper-case? (string-ref nstr (+ -1 idx)))
-		(char-lower-case? (string-ref nstr idx)))
-	   (set! nstr
-		 (string-append (substring nstr 0 (+ -1 idx))
-				"-"
-				(substring nstr (+ -1 idx)
-					   (string-length nstr)))))
-	  ((and (char-lower-case? (string-ref nstr (+ -1 idx)))
-		(char-upper-case? (string-ref nstr idx)))
-	   (set! nstr
-		 (string-append (substring nstr 0 idx)
-				"-"
-				(substring nstr idx
-					   (string-length nstr)))))))
-  nstr)
+(define progname (if (defined? *optind*)
+		     (list-ref *argv* (+ -1 *optind*))
+		     (car (program-arguments))))
 
 ;; SCHEMEIFY-NAME:
 ;; * Changes _ to -
@@ -93,8 +80,8 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
   (let ((sid (string-index nstr #\-)))
     (cond ((and pre sid (< sid 3)) (string-set! nstr sid #\:)
 	   nstr)
-	  (pre (string-append pre (StudlyCaps->dashed-name nstr)))
-	  (else (StudlyCaps->dashed-name nstr)))))
+	  (pre (string-append pre (StudlyCapsExpand nstr)))
+	  (else (StudlyCapsExpand nstr)))))
 
 (define (extract-structs port)
   (define typedef-struct (string-append (string #\newline) "typedef struct {"))
@@ -241,54 +228,91 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
   (let ((structs (remove-if-not
 		  (lambda (struct) (substring? "Event" (car struct)))
 		  (call-with-input-file filename extract-structs))))
-    (call-with-output-file "xevent.h"
-      (lambda (xevent.h)
-	(fprintf xevent.h "/* %s extracted typedef structs from %s */\n"
-		 (car *argv*) filename)
-	(fprintf xevent.h
-		 "#ifdef SCM_EVENT_FIELDS\n")
-	(call-with-output-file "xevent.scm"
-	  (lambda (xevent.scm)
-	    (define evs #f)
-	    (fprintf xevent.scm ";; %s extracted typedef structs from %s\n"
-		     (car *argv*) filename)
-	    (for-each
-	     (lambda (struct)
-	       (define name (car struct))
-	       (set! evs (assoc name event-map))
-	       (and
-		evs
-		(for-each
-		 (lambda (decl)
-		   (define typ (string->symbol (car decl)))
-		   (casev typ
-		     ((,Bool ,Time int char)
-		      (fprintf xevent.h "  ")
-		      (for-each (lambda (event-name)
-				  (fprintf xevent.h "case (%s<<8)+0x%02x: "
-					   event-name
-					   (do-field xevent.scm (cadr decl))))
-				(cdr evs))
-		      (fprintf xevent.h "return %s(((%s *) x)->%s);\n"
-			       (casev typ
-				 ((,Bool) "x_make_bool")
-				 ((,Time) "ulong2num")
-				 ((int char) "MAKINUM"))
-			       name
-			       (cadr decl)))
-		     ;;(else (print 'typ typ))
-		     ))
-		 (cdr struct))))
-	     structs)))
-	(fprintf xevent.h "#else\n")
-	(for-each (lambda (apr)
-		    (for-each (lambda (evnt)
-				(fprintf xevent.h
-					 "  {%-20s \"%s\"},\n"
-					 (string-append evnt ",") evnt))
-			      (cdr apr)))
-		  event-map)
-	(fprintf xevent.h "#endif\n")))))
+    (call-with-open-ports
+     (open-file "xevent.h" "w")
+     (open-file "xevent.scm" "w")
+     (lambda (xevent.h xevent.scm)
+       (define evs #f)
+       (fprintf xevent.h "/* %s extracted typedef structs from %s */\n"
+		progname filename)
+       (fprintf xevent.h
+		"#ifdef SCM_EVENT_FIELDS\n")
+       (fprintf xevent.scm ";; %s extracted typedef structs from %s\n"
+		progname filename)
+       (for-each
+	(lambda (struct)
+	  (define name (car struct))
+	  (set! evs (assoc name event-map))
+	  (and
+	   evs
+	   (for-each
+	    (lambda (decl)
+	      (define typ (string->symbol (car decl)))
+	      (qase typ
+		((,Bool ,Time int char)
+		 (fprintf xevent.h "  ")
+		 (for-each (lambda (event-name)
+			     (fprintf xevent.h "case (%s<<8)+0x%02x: "
+				      event-name
+				      (do-field xevent.scm (cadr decl))))
+			   (cdr evs))
+		 (fprintf xevent.h "return %s(((%s *) x)->%s);\n"
+			  (qase typ
+			    ((,Bool) "x_make_bool")
+			    ((,Time) "ulong2num")
+			    ((int char) "MAKINUM"))
+			  name
+			  (cadr decl)))
+		;;(else (print 'typ typ))
+		))
+	    (cdr struct))))
+	structs)
+       (fprintf xevent.h "#else\n")
+       (for-each (lambda (apr)
+		   (for-each (lambda (evnt)
+			       (fprintf xevent.h
+					"  {%-20s \"%s\"},\n"
+					(string-append evnt ",") evnt))
+			     (cdr apr)))
+		 event-map)
+       (fprintf xevent.h "#endif\n")))))
+
+(define (xatoms)
+  (define /usr/include/X11/Xatom.h "/usr/include/X11/Xatom.h")
+  (define /usr/include/X11/Xcms.h "/usr/include/X11/Xcms.h")
+  (call-with-open-ports
+   (open-file /usr/include/X11/Xatom.h "r")
+   (open-file "/usr/include/X11/Xcms.h" "r")
+   (open-file "xatoms.scm" "w")
+   (lambda (xatom.h xcms.h xatoms.scm)
+     (fprintf xatoms.scm ";; %s extracted definitions from %s\n"
+	      progname /usr/include/X11/Xatom.h)
+     (do ((line (read-line xatom.h) (read-line xatom.h)))
+	 ((eof-object? line))
+       (let ((lst (scanf-read-list "#define XA_%s ((Atom) %d)" line)))
+	 (and (list? lst)
+	      (case (length lst)
+		((2) (fprintf xatoms.scm "(define %s %d)\n"
+			      (string-subst (car lst) "_" "-")
+			      (cadr lst)))
+		((0) #f)		;(write-line line)
+		(else (slib:error 'xatom.h 'line line))))))
+     (fprintf xatoms.scm ";; %s extracted definitions from %s\n"
+	      progname /usr/include/X11/Xcms.h)
+     (do ((line (read-line xcms.h) (read-line xcms.h)))
+	 ((eof-object? line))
+       (let ((lst (scanf-read-list "#define Xcms%s (XcmsColorFormat)0x%4x%4x"
+				   line)))
+	 (and (list? lst)
+	      (case (length lst)
+		((3) (apply fprintf xatoms.scm "(define\tX:%s\t#x%04x%04x)\n"
+			    (string-subst (car lst) "Format" "")
+			    (cdr lst)))
+		((2) (fprintf xatoms.scm "(define\tX:%s\t#x%08x)\n"
+			      (string-subst (car lst) "Format" "")
+			      (cadr lst)))
+		((0 1) #f)
+		(else (slib:error 'xcms.h 'line line)))))))))
 
 (go-script)